       CBL SIZE(MAX)
       IDENTIFICATION DIVISION.
       PROGRAM-ID.        OPPSCAL.
      *AUTHOR.            CMS - GF.
      *REMARKS.           CMS.
      ***********************************************************
      *                                                         *
      *                 OPPS PRICER CHANGE LOG                  *
      *                                                         *
      ***********************************************************
      * 11/13/06- ADDED 6000 SECTION FOR CY2007                 *
      *           REDEFINE OF UNUSED L-PROV-SPEC-AREA FIELD     *
      *              BEFORE                                     *
      *                  L-PSF-BED-SIZE               PIC 9(5)  *
      *              AFTER                                      *
      *                  L-PSF-STATE-CODE             PIC 9(02) *
      *                  L-PSF-TOPS-INDICATOR         PIC X(01) *
      *                  L-PSF-HOSP-QUAL-IND          PIC X(01) *
      *                  FILLER                       PIC X(01) *
      *                                                         *
      *           MOVE 992 TO H-IP-LIMIT.                       *
      *           OUTLIER HOSPITAL THRESHOLD OF $1825.          *
      *           NEW WAC TABLE RENAMED PD-AT-CST-W-COIN7.      *
      *           ADDED MANY COMMENTS.                          *
      *           MOVED PROCEDURE DIV. PARAGRAPHS TO COLUMN 8.  *
      *           NEW BLOOD RANKING TABLE FOR 2007.             *
      *           NEW 2007 BRACH & RADIOPHARM TABLE FOR 20% COIN*
      *           NEW COPYBOOK OPPSOF07 FOR 2007 OFFSETS.       *
      *           NEW COPYBOOK DEVRED07 FOR 2007 DEVICE REDUCT. *
      *           INITIALIZED BLOOD FRACTION IN PARAGRAPH       *
      *             6550-CALC-STANDARD.                         *
      *           ALLOW OPPS- YMT-ADJ-FLAG VALUE OF ' 7'        *
      *           ALLOW OUTLIER PAYMENT TO CERTAIN BRACHYTHERAPY*
      *             CODES WHEN SERVICE INDICATOR IS K IN        *
      *             PARAGRAPH 6600-ADJ-CHRG-OUTL.               *
      * 12/12/06- REMOVED BRACHYTHERAPY CODES FROM OUTLIER LOGIC*
      *           & ADDED THEM TO THE PD-AT-CST LIST TABLE.     *
      *                                                         *
      * 02/20/07- ADDED APC 00039 TO OFFSET TABLES FOR 2006 &   *
      *           2007.  ALSO ADDED CODE TO 5160-TOTAL & TO     *
      *           6160-TOTAL PARAGRAPHS TO CHECK THAT OFFSET    *
      *           DOES NOT RESULT IN A LINE PAYMENT LESS THAN   *
      *           ZERO.                                         *
      * 04/01/07- PROPOSED:                                     *
      *           ADDED CODE TO 5160-TOTAL & TO 6160-TOTAL      *
      *           TO PERFORM 5161 & 6161 RESPECTIVELY. THE      *
      *           OFFSET CALCULATIONS WILL BE SKIPPED IN THE    *
      *           *161 PARAGRAPHS IF THE OFFSET AMOUNT IS ZERO  *
      *           WHEN A HIT IS MADE WHEN LOOKING UP THE APC.   *
      *                                                         *
      * 05/10/07- VERSION 2007.3.0 UPDATES:                     *
      *           NEW PAID-AT-COST WITH 20% COINSURANCE TABLE   *
      *           EFFECTIVE JULY 1, 2007 FOR SPECIFIED          *
      *           RADIOPHARMS & BRACHYTHERAPY (INCLUDES NEW     *
      *           LOOK-UP LOGIC IN PARAGRAPH 6550-CALC-STANDARD)*
      *                                                         *
      *           ADDED CODE TO 5160-TOTAL & TO 6160-TOTAL      *
      *           TO PERFORM 5161 & 6161 RESPECTIVELY. THE      *
      *           OFFSET CALCULATIONS WILL BE SKIPPED IN THE    *
      *           *161 PARAGRAPHS IF THE OFFSET AMOUNT IS ZERO  *
      *           WHEN A HIT IS MADE WHEN LOOKING UP THE APC.   *
      *                                                         *
      *           APC 00034 ADDED - EFFECTIVE 01/01/2007        *
      *                                                         *
      *           14 APC UPDATES EFFECTIVE 07/01/2007           *
      *                                                         *
      * 06/18/07- VERSION 2007.3.1 UPDATE:                      *
      *           APC TABLE CORRECTED TO INCLUDE 04/01/2007     *
      *           RECORDS AND UPDATES THAT WERE OMITTED FROM    *
      *           VERSION 2007.3.0.                             *
      *                                                         *
      * 06/21/07- VERSION 2007.3.2 UPDATE:                      *
      *           APC TABLE UPDATED WITH THE JULY 2007 ASP DRUG *
      *           RATES AND OTHER RETROACTIVE RATE UPDATES.     *
      *                                                         *
      * 06/27/07- VERSION 2007.3.3 UPDATE:                      *
      *           APC TABLE CORRECTIONS MADE:                   *
      *           - APCS 00844, 01695, & 09002 - 20070701       *
      *             RECORDS' PAYMENT RATES CORRECTED            *
      *           - APC 02632 - 20070101 RECORD PMT RATE        *
      *             CHANGED FROM 'DELETED' (INCORRECTLY DELETED *
      *             IN VERSION 2007.2.1) TO '0000000.'          *
      *                                                         *
      * 07/03/07- VERSION 2007.3.4 UPDATE:                      *
      *           APC TABLE CORRECTION MADE FOR APC 00951       *
      *           (PAYMENT RATES & COINSURANCE CORRECTED)       *
      *                                                         *
      * 08/10/07- VERSION 2007.4.0 UPDATE:                      *
      *           1) UPDATE DEVICE REDUCTION TABLE              *
      *              - APC 315 -> $12,422.60 EFFECTIVE 1/1/07   *
      *              - APC 385 -> $ 2,282.53 EFFECTIVE 1/1/07   *
      *           2) REMOVE HOSPITALS 330044 AND 330245 FROM    *
      *              401 HOSPITAL LOGIC EFFECTIVE 1/1/07        *
      *                                                         *
      * 08/21/07- PREPARE FOR VERSION 2008.1.0 UPDATE:          *
      *           ADDED 7000-... PARAGRAPHS TO PREPARE FOR      *
      *           JANUARY 2008 RELEASE                          *
      *                                                         *
      * 10/30/07- VERSION 2008.1.0 UPDATES:                     *
      * THROUGH   - DOCUMENT ENTIRE PROGRAM (COMMENTS)          *
      * 12/07/07  - CREATED CAL-VERSION7                        *
      *           - NEW APC TABLE                               *
      *           - NEW CBSA WAGE INDEX TABLE                   *
      *           - NEW OFFSET TABLE (ALL OFFSETS = $0)         *
      *           - NEW DEVICE REDUCTION TABLE                  *
      *           - NEW BLOOD DEDUCTIBLE HCPCS TABLE            *
      *           - TABLE FOR COMPOSITE APCS CREATED            *
      *           - TABLE FOR MENTAL HEALTH (MH) HCPCS CREATED  *
      *           - TABLE FOR PARTIAL HOSPITALIZATION (PHP)     *
      *             HCPCS CREATED                               *
      *           - NEW FLAGS: APC34-FLAG, PHP-HCPCS-FLAG,      *
      *             MH-HCPCS-FLAG, BRACHY-APC-FLAG, &           *
      *             BLD-DEDUC-HCPCS-FLAG                        *
      *           - NEW INPATIENT LIMIT (H-IP-LIMIT) = $1,024   *
      *           - NEW OUTLIER THRESHOLD = $1,575              *
      *           - NEW CY 2008 CBSA WAGE INDEX FLOORS          *
      *           - NEW CY 2008 SECTION 401 HOSPITALS           *
      *           - REMOVED PAID AT COST LOGIC - PARAGRAPHS     *
      *             7550-PD-AT-CST-JAN07 & 7550-PD-AT-CST-JUL07 *
      *           - PHP & MH HCPCS ADDED TO LINE ITEM ACTION    *
      *             FLAG VALIDATION LOGIC                       *
      *           - NEW PAYMENT ADJUSTMENT FLAG OF ' 8' &       *
      *             CORRESPONDING PARTIAL CREDIT DEVICE         *
      *             REDUCTION LOGIC ADDED - 7550-DEVICE-COMPUTE *
      *             (APC PMT REDUCED BY 1/2 THE REDUCTION AMT)  *
      *           - PHP HCPCS ADDED TO SITE OF SERVICE VALIDA-  *
      *             TION LOGIC                                  *
      *           - ADDED LOGIC TO EXCLUDE COMPOSITE AND MENTAL *
      *             HEALTH CHARGES FROM TOTAL CLAIM PACKAGED    *
      *             CHARGES                                     *
      *           - ADDED LOGIC TO ACCUMULATE PACKAGED MENTAL   *
      *             HEALTH CHARGES & ADD THEM TO THE APC 34     *
      *             LINE'S CHARGES FOR OUTLIER CALCULATION      *
      *           - ADDED LOGIC TO ACCUMULATE NON-PRIME         *
      *             COMPOSITE APC CHARGES & ADD THEM TO THE     *
      *             PRIME LINE'S CHARGES FOR OUTLIER CALC       *
      *             (NEW PARAGRAPHS: 7170-COMPOSITES,           *
      *              7171-SEARCH-PAF, 7172-ADD-ENTRY,           *
      *              7173-UPDATE-ENTRY, 7174-STAGE-CMP-ENTRY)   *
      *           - ADDED DISCOUNT FACTOR VALUE OF 9 &          *
      *             CORRESPONDING DISCOUNT CALCULATION          *
      *           - 7560-CALC-BENE-DEDUCT PERFORM MOVED FROM    *
      *             7550-SCH-ADJ TO 7550-CALC-STANDARD          *
      *           - LIST OF BRACHYTHERAPY APCS CREATED IN NEW   *
      *             PARAGRAPH 7650-SET-BRACHY-APC-FLAG          *
      *           - NEW LIST OF BLOOD DEDUCTIBLE HCPCS IN NEW   *
      *             PARAGRAPH 7655-SET-BD-HCPCS-FLAG            *
      *           - 7550-CALC-GJK MODIFIED TO CHECK BLOOD       *
      *             DEDUCTIBLE HCPCS FLAG INSTEAD OF LIST       *
      *           - 7550-SCH-ADJ & 7550-CALC-GJK MODIFIED TO    *
      *             APPLY THE SOLE COMMUNITY HOSPITAL ADJ. TO   *
      *             BRACHYTHERAPY & BLOOD LINES WHEN APPLICABLE *
      *           - ADDED LOGIC TO CALCULATE LINE REIMBURSEMENT *
      *             & NATIONAL COININSURANCE TO PARAGRAPH       *
      *             7550-CALC-STANDARD (COPIED FROM LOGIC IN    *
      *             7550-PD-AT-CST-JAN07, WHICH WAS DELETED     *
      *             ALONG WITH 7550-PD-AT-CST-JUL07 FOR CY 2008)*
      *                                                         *
      * 12/17/07- VERSION 2008.1.1 UPDATES:                     *
      *           - REVISED STEP #12 & #13 IN THE PRICING       *
      *             PROCESS OVERVIEW FOR THE 7000 SECTION       *
      *           - ADDED A PERIOD AFTER THE H-NAT-COIN COMPUTE *
      *             IN PARAGRAPH 7550-CALC-STANDARD & MOVED     *
      *             H-MIN-COIN MOVE STATEMENT                   *
      *                                                         *
      * 12/27/07- VERSION 2008.1.2 UPDATES:                     *
      *           - BRACHYTHERPY AND RADIOPHARM LINES' STATUS   *
      *             INDICATORS CHANGED BACK TO 'H' IN THE OCE   *
      *           - INSERT PAID-AT-COST LOGIC FOR BRACHYTHERAPY *
      *             AND RADIOPHARM LINES                        *
      *             - NO PAID-AT-COST TABLE FOR 2008            *
      *             - RADIOPHARM APCS ARE IDENTIFIED BY         *
      *               RADIOPH-APC-FLAG = 'Y'                    *
      *               NEW PARAGRAPH: 7660-SET-RADIOPH-APC-FLAG  *
      *             - BRACHYTHERAPY APCS ARE IDENTIFIED BY      *
      *               BRACHY-APC-FLAG = 'Y'                     *
      *           - NEW LOGIC FOR BRACHYTHERAPY LINES WITH A    *
      *             STATUS INDICATOR OF 'K' RETAINED BECAUSE    *
      *             NO LINES WILL MEET THE CRITERIA; AND        *
      *             THEREFORE, NO CLAIMS WILL BE AFFECTED       *
      *                                                         *
      * 02/08/08 - UPDATED RECORDS OF 24 APCS IN THE APC TABLE  *
      *            THESE RECORDS INCORRECTLY HAD A STATUS       *
      *            INDICATOR OF 'K' IN THE JANUARY RELEASE,     *
      *            THEIR STATUS INDICATORS WERE CHANGED TO 'H'  *
      *            AND THEIR PAYMENT RATES AND COINSURANCE      *
      *            AMOUNTS WERE CHANGED TO $0                   *
      *                                                         *
      * 02/08/08 - ADDED NEW TABLES AND LOGIC FOR ADDING PASS-  *
      * THROUGH    THROUGH DEVICE CHARGES AND PAYMENTS TO ELIG- *
      * 02/14/08   IGIBLE PROCEDURES FOR OUTLIER DETERMINATION  *
      *          - IN PARAGRAPH 7600-ADJ-CHRG-OUT, A-LITEM-PYMT *
      *            IS NO LONGER USED IN THE OUTLIER CALCS.      *
      *            H-LITEM-PYMT-OUTL IS USED INSTEAD            *
      *          - USES NEW APC TABLE THAT INCLUDES STATUS      *
      *            INDICATOR CHANGES FOR 24 APCS (FROM K TO H)  *
      *            AND 2 DELETED HCPCS EFFECTIVE 4/1/08 (APCS   *
      *            1691 & 1692)                                 *
      *          - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES IN *
      *            PARAGRAPH 7600-ADJ-CHRG-OUT                  *
      *          - CODE CHANGES AND ADDITIONS ARE AS FOLLOWS:   *
      *                                                         *
      *            LOGIC ADDED TO                               *
      *            PARAGRAPHS:     7150-INIT                    *
      *                            7125-INIT                    *
      *                            7400-CALCULATE               *
      *                            7555-CALC-H-STANDARD         *
      *                            7600-ADJ-CHRG-OUTL           *
      *                                                         *
      *            NEW TABLES:     W-PTD-PROC-HCPCS-TBL         *
      *                            W-PASS-THRU-DEV-PTR-TABLE    *
      *                                                         *
      *            NEW PARAGRAPHS: 7390-PASS-THRU-DEVICES       *
      *                            7391-STAGE-ENTRY             *
      *                            7392-PASS-THRU-DEV-PROCS     *
      *                            7393-PERFORM-SEARCH          *
      *                            7394-SEARCH-PTD-HCPCS        *
      *                            7395-UPDATE-ENTRY            *
      *                            7610-PERFORM-SEARCH          *
      *                            7611-SEARCH-PTD-HCPCS        *
      *                                                         *
      *            NEW VARIABLES:  PTD-FLAG                     *
      *                            PTD-LINE-FLAG                *
      *                            PTD-PROC-FLAG                *
      *                            W-PTD-LINE-HCPCS             *
      *                            W-PTD-CNT                    *
      *                            W-PTD-PROC-SUB               *
      *                            W-END-OF-PTD-TBL             *
      *                            W-PTD-MAX                    *
      *                            H-PTD-UNIT-RATE              *
      *                            H-PTD-SUB-CHRG               *
      *                            H-PTD-LITEM-PYMT             *
      *                            H-LITEM-PYMT-OUTL            *
      *                                                         *
      * 03/20/08- UPDATED APC TABLE WITH ASP DRUGS              *
      *                                                         *
      * 05/13/08- UPDATED APC TABLE WITH THERAPEUTIC RADIOPHARM *
      *           & BRACHYTHERAPY APC SI CHANGE TO ' K' AND TWO *
      *           DRUG APCS' SI CHANGE FROM ' K' TO ' G'        *
      *           (26 TOTAL APC CHANGES)                        *
      *                                                         *
      *           NEW HANDLING OF THERAPEUTIC RADIOPHARMS &     *
      *           BRACHYTHERAPY LINES EFFECTIVE 7/1/2008        *
      *           (LOGIC CREATED IN JANUARY, ENABLED BY THE     *
      *           SI CHANGE TO ' K' ON 7/1/2008)                *
      *           - BRACHYTHERAPIES ARE ELIGIBLE FOR OUTLIER;   *
      *             THERAPEUTIC RADIOPHARMS ARE NOT             *
      *           - BRACHYTHERAPIES & THERAPEUTIC RADIOPHARMS   *
      *             ARE NO LONGER PAID-AT-COST                  *
      *           - BRACHYTHERAPIES ARE ELIGIBLE FOR SCH ADJ.;  *
      *             THERAPEUTIC RADIOPHARMS ARE NOT             *
      *                                                         *
      * 06/23/08- UPDATED APC TABLE WITH ASP DRUGS              *
      *           (271 TOTAL APC CHANGES)                       *
      *                                                         *
      * 08/07/08- UPDATED APC TABLE FOR OCTOBER 2008 RELEASE    *
      *           - CHANGED STATUS INDICATOR OF BRACHYTHERAPY   *
      *             SOURCE & THERAPEUTIC RADIOPHARM APCS FROM   *
      *             'K' BACK TO 'H' - EFFECTIVE 7/1/2008 FOR    *
      *             24 APCS                                     *
      *           - CHANGED STATUS INDICATOR OF APC 1711 FROM   *
      *             'K' TO 'G' EFFECTIVE 10/1/2008              *
      *           UPDATED PROGRAM COMMENTS FOR BRACHYTHERAPY &  *
      *           THERAPEUTIC RADIOPHARM SI CHANGE AND          *
      *           REVISED MENTAL HEALTH PACKAGING COMMENT IN    *
      *           THE OUTLIER ROUTINE.                          *
      *                                                         *
      * 08/08/08- CORRECTED PACKAGING LOGIC FOR MENTAL HEALTH   *
      *           CLAIMS EFFECTIVE RETROACTIVE TO JANUARY 1,    *
      *           2008 IN PARAGRAPH 7150-INIT.                  *
      *                                                         *
      * 09/18/08- ADDED ASP DRUG UPDATES, APC RATE CORRECTIONS, *
      *           & 3 NEW APCS EFFECTIVE 10/01/2008 TO THE APC  *
      *           TABLE (251 CHANGES & ADDITIONS).  UPDATED     *
      *           PRICER VERSION NUMBER TO 2008.4.1.            *
      *                                                         *
      * 11/03/08- CY 2009 UPDATES - VERSION 2009.1.0            *
      *           - ADDED NEW COPY STATEMENTS FOR TABLES        *
      *           - CREATED NEW 8000- SECTION                   *
      *           - ADDED FY 2009 FLOOR LOGIC                   *
      *           - ADDED FY 2009 401 HOSPITAL LOGIC            *
      *           - CHANGED PARTIAL HOSPITALIZATION APC FLAG    *
      *             FROM APC33-FLAG TO PHP-APC-FLAG & UPDATED   *
      *             RELATED LOGIC                               *
      *                                                         *
      * 11/10/08- - ADDED SSRFBN09 TABLE AND COPY STATMENT      *
      *           - ADDED LOGIC TO APPLY SSRFBN TO CBSA WAGE    *
      *             INDEX VALUES BY PROVIDER STATE - ADDED      *
      *             PARAGRAPHS (LOGIC ADAPTED FROM LTCH PRICER  *
      *             V 2009.3 PROGRAM LTCAL093)                  *
      *           - UPDATED DAILY INPATIENT COINSURANCE LIMIT   *
      *             TO $1068                                    *
      *           - UPDATED OUTLIER THRESHOLD TO $1800          *
      *           - UPDATED THE OCE RECORD LAYOUT:              *
      *             - SERVICE UNITS INCREASED FROM 7 TO 9 BYTES *
      *             - ADDED COMPOSITE ADJUSTMENT FLAG, 2 BYTES  *
      *               (OPPS-COMP-ADJ-FLAG)                      *
      *                                                         *
      * 11/12/08- - DISABLED LOGIC THAT FLAGS CLAIMS WITH       *
      *             HCPCS C1820 B/C NO HCPCS ARE ELIGIBLE FOR   *
      *             PASS-THROUGH FOR CY 2009 (7125-INIT)        *
      *           - REMOVED PASS-THROUGH DEVICE (PTD) LIST &    *
      *             PROCEDURES ELIGIBLE FOR PTD LIST B/C THERE  *
      *             ARE NO PAIRINGS FOR CY 2009                 *
      *             (8665-SET-PTD-LINE-FLAG,                    *
      *              8670-SET-PTD-PROC-FLAG)                    *
      *           - CHANGED SECOND PTD-FLAG CHECK IN PARAGRAPH  *
      *             8600-ADJ-CHRG-OUTL TO PTD-PROC-FLAG CHECK   *
      *           - CHANGE LOGIC TO LOOK AT COMPOSITE ADJUSTMENT*
      *             FLAG (NEW FOR CY 2009) INSTEAD OF PAYMENT   *
      *             ADJUSTMENT FLAGS 91 - 99 TO ID COMPOSITES   *
      *           - BRACHYTHERAPY APC LIST REMOVED,             *
      *             BRACHYTHERAPY LINES NOW IDENTIFIED WITH A   *
      *             STATUS INDICATOR OF ' U'                    *
      *             PARAGRAPH 8650-SET-BRACHY-APC-FLAG DISABLED *
      *           - ADDED ' U' AND ' R' TO LIST OF VALID STATUS *
      *             INDICATORS FOR BRACHY AND BLOOD LINES       *
      *                                                         *
      * 11/13/08- - EXCLUDED THERAPEUTIC RADIOPHARM LINES FROM  *
      *             CLAIM DEVICE UNITS CALC, CLAIM DEVICE       *
      *             CHARGES CALC, AND WAGE ADJ DEVICE OFFSET    *
      *             CALC                                        *
      *           - EXCLUDED BRACHYTHERAPIES FROM OUTLIER CALC  *
      *           - ADDED VARIABLES AND CALC LINE PAYMENTS FOR  *
      *             APC 0173 - WITH AND WITHOUT SCH ADJ.        *
      *           - ALTERED PHP OUTLIER LOGIC TO ALWAYS USE THE *
      *             PHP "CAP" APC'S LINE PAYMENT IN THE CALC    *
      *           - EXCLUDED BRACHY LINES FROM ALL DEVICE LOGIC *
      *           - ADDED REDUCED UPDATE RATIO FOR HOSPITAL     *
      *             QUALITY INDICATOR, PAR 8180-REDUCE-APC-PYMT *
      *           - REVISED ALL SI = K LOGIC TO ACCOMODATE      *
      *             BLOOD DEDUCTIBLE LINE SI CHANGE FROM K TO R *
      *             (SCH PYMT, BLOOD DEDUCTIBLE CALCS)          *
      *                                                         *
      * 11/24/08- - REVISED COMMENT IN 8560-CALC-BENE-DEDUCT    *
      *             TO EXPLAIN THAT LINES WITH A PAF=4 ARE      *
      *             CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      *                                                         *
      * 12/02/08- - INCREASED H-SRVC-UNITS, W-BD-SRVC-UNITS,    *
      *             AND W-SRVC-UNITS FROM 7 TO 9 BYTES          *
      *           - INCREASED FILLER IN GROUP OCE-IN-DATE       *
      *             FROM 21 TO 23 TO ACCOUNT FOR INCREASE IN    *
      *             UNITS                                       *
      *                                                         *
      * 12/05/08- - ASSIGNED RETURN CODE 11 IN PARAGRAPH        *
      *             8180-REDUCE-APC-PYMT WHEN THE ABSENCE OF    *
      *             QUALITY REPORTING LEADS TO A REDUCED PMT,   *
      *             ADDED SI=R TO ELIGIBLE SI LIST              *
      *           - CORRECTED SCH LOGIC TO CALCULATE BLOOD      *
      *             LINES INELIGIBLE FOR A DEDUCTIBLE           *
      *           - IN PARAGRAPH 8550-CALC-GJK, CORRECTED LOGIC *
      *             TO CALCULATE THE SCH ADJUSTMENT (WHEN       *
      *             APPLICABLE) FOR BLOOD LINES THAT DON'T HAVE *
      *             A PAF OF 5 OR 6                             *
      *           - IN PARAGRAPH 8600-ADJ-CHRG-OUTL ADDED       *
      *             SI=K TO LIST OF SIS INELIGIBLE FOR OUTLIERS *
      *                                                         *
      * 12/18/08- CREATE VERSION 2009.1.1                       *
      *           - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (325 TOTAL APC CHANGES)                     *
      *                                                         *
      * 02/09/09- CREATE VERSION 2009.2.0 (FOR APRIL 2009)      *
      * 2009.2.0  ADD COMMENT TO PARAGRAPH 7600-ADJ-CHRG-OUTL   *
      *           TO EXPLAIN THAT NO CY 2008 BLOOD LINES ARE    *
      *           PAID AN OUTLIER                               *
      *                                                         *
      * 02/10/09- ADD COMMENTS TO WORKING STORAGE SECTION       *
      * 2009.2.0  MOVED LOCATION OF PASS-THROUGH DEVICE         *
      *           PROCEDURE TABLE IN WORKING STORAGE FOR        *
      *           ORGANIZATIONAL PURPOSES                       *
      *                                                         *
      * 02/10/09- ADD LOGIC TO PROCESS PASS-THROUGH             *
      * THROUGH   RADIOPHARMACEUTICAL OFFSETS                   *
      * 02/13/09                                                *
      * 2009.2.0  NEW COPYBOOKS:                                *
      *               - PT RADIOPHARM HCPCS TABLE (OPPSPTRH)    *
      *                 (HCPCS WITH EFFECTIVE DATE &            *
      *                  TERMINATION DATE)                      *
      *               - PT RADIOPHARM OFFSET TABLE (OPPSPTRO)   *
      *                 (NUCLEAR APCS WITH OFFSET               *
      *                  AMOUNTS & EFFECTIVE YEAR)              *
      *                                                         *
      *           NEW WORKING-STORAGE TABLE:                    *
      *               - W-NUCMED-APC-TBL                        *
      *                                                         *
      *           NEW VARIABLES:                                *
      *               - PTRADIO-CLAIM-FLAG                      *
      *               - PTRADIO-LINE-FLAG                       *
      *               - W-PTRADIO-LINE-HCPCS                    *
      *               - W-PTRADIO-CHRG-RATE                     *
      *               - W-PTRADIO-LINE-OFFSET                   *
      *               - NUCMED-LINE-FLAG                        *
      *               - W-NUCMED-LINE-APC                       *
      *               - W-NUCMED-SUB                            *
      *               - W-NUCMED-UNIT-CNT                       *
      *               - W-END-OF-NUCMED-TBL                     *
      *               - W-NUCMED-OFFSET                         *
      *               - W-NUCMED-WA-OFFSET                      *
      *               - W-LINE-SRVC-DATE                        *
      *               - H-PTRADIO-TOT-CHRGS                     *
      *               - H-NUCMED-TOT-OFFSET                     *
      *               - H-PTRADIO-HCPCS-CNT                     *
      *                                                         *
      *           NEW PARAGRAPHS:                               *
      *               - 8165-PROCESS-NUCLEAR-MED                *
      *               - 8166-LOAD-NUCMED-TABLE                  *
      *               - 8167-STAGE-NUCMED-ENTRY                 *
      *               - 8550-PTRADIO-OFFSET                     *
      *               - 8680-SET-PTRADIO-LINE-FLAG              *
      *                                                         *
      *           EXISTING PARAGRAPHS WITH NEW LOGIC:           *
      *               - 8000-PROCESS-MAIN-NEW                   *
      *               - 8100-INIT                               *
      *               - 8125-INIT                               *
      *               - 8150-INIT                               *
      *               - 8550-CALC-STANDARD                      *
      *                                                         *
      * 03/19/09- CREATE VERSION 2009.2.1                       *
      * 2009.2.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (254 TOTAL APC CHANGES)                     *
      *                                                         *
      * 03/26/09- CREATE VERSION 2009.2.2                       *
      * 2009.2.2  - CORRECTED MEMBERS OPPSPTRO AND BASEPTRO BY  *
      *             ADDING APC 00414 TO NUCLEAR MEDICINE LIST   *
      *             PER HPAR CR6416H                            *
      *                                                         *
      * 05/08/09- CREATE VERSION 2009.3.0                       *
      * 2009.3.0  UPDATED WORKING STORAGE VERSION NUMBER        *
      *                                                         *
      * 05/11/09- REVISED LOGIC THAT IDENTIFIES LINES ELIGIBLE  *
      * 2009.3.0  FOR BLOOD DEDUCTIBLE FOR YEARS 2005 - 2009.   *
      *           IN ADDITION TO HAVING A HCPCS IN BD TABLE,    *
      *           OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')  *
      *           EXISTING PARAGRAPHS WITH NEW LOGIC:           *
      *               - 4150-INIT                               *
      *               - 5150-INIT                               *
      *               - 6150-INIT                               *
      *               - 7150-INIT                               *
      *               - 8150-INIT                               *
      *               - 8550-SCH-ADJ                            *
      *                                                         *
      * 05/12/09- REVISED LOGIC FOR YEARS 2005 - 2008 TO ALLOW  *
      * 2009.3.0  ALL BLOOD LINES TO ENTER THE OUTLIER LOGIC BY *
      *           IDENTIFYING BLOOD LINES BY HCPCS              *
      *           NEW TABLE:    W-2005-2008-BLOOD-HCPCS-TABLE   *
      *           NEW VARIABLE: W-BLD-HCPCS-FLAG                *
      *           EXISTING PARAGRAPHS WITH NEW LOGIC:           *
      *               - 4600-ADJ-CHRG-OUTL                      *
      *               - 5600-ADJ-CHRG-OUTL                      *
      *               - 6600-ADJ-CHRG-OUTL                      *
      *               - 7600-ADJ-CHRG-OUTL                      *
      *                                                         *
      * 05/12/09- REVISED CY 2008 LOGIC FOR MENTAL HEALTH       *
      * 2009.3.0  COMPOSITES TO DISTRIBUTE PACKAGED MENTAL      *
      *           HEALTH CHARGES EVENLY TO ALL PAYABLE APC 34   *
      *           LINES ON THE CLAIM                            *
      *           NEW VARIABLE: W-APC34-CNT                     *
      *           EXISTING PARAGRAPHS WITH NEW LOGIC:           *
      *               - 7125-INIT                               *
      *               - 7600-ADJ-CHRG-OUTL                      *
      *                                                         *
      * 05/14/09- CORRECTED FORMAT OF FIELD W-BD-RANK           *
      * 2009.3.0  CHANGED FROM PIC 9(05) TO PIC 9(02)           *
      *           AFFECTS BLOOD DEDUCTIBLE PAYMENTS FOR YEARS   *
      *           2005 THROUGH 2009; BEFORE CORRECTION BLOOD    *
      *           DEDUCTIBLE APC LINES WERE NOT ORDERED FROM    *
      *           LOWEST TO HIGHEST RANK (APC PMT) AS INTENDED  *
      *                                                         *
      * 06/18/09- CREATE VERSION 2009.3.1                       *
      * 2009.3.1  - ADDED PERIODS TO END IF STATEMENTS IN       *
      *             PARAGRAPH 4550-ADJ-PLATE-COST               *
      *           - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (270 TOTAL APC CHANGES)                     *
      *           - UPDATED WORKING STORAGE VERSION NUMBER      *
      *           - UPDATED CAL-VERSION TO REFLECT THE THIRD    *
      *             QUARTER UPDATE                              *
      *                                                         *
      * 06/23/09- CREATE VERSION 2009.3.2                       *
      * 2009.3.2  - UPDATED APC TABLE WITH JULY ASP DRUG RATES  *
      *             (270 TOTAL APC CHANGES; 2 CHANGES SINCE THE *
      *              LAST RELEASE: CORRECTIONS TO RATES OF APCS *
      *              01608 AND 01686)                           *
      *           - UPDATED WORKING STORAGE VERSION NUMBER      *
      *                                                         *
      * 08/07/09- CREATE VERSION 2009.4.0 (OCTOBER 2009)        *
      * 2009.4.0  - REVISED LOGIC TO ENSURE ELIGIBLE BLOOD      *
      *             LINES RECEIVE THE SOLE-COMMUNITY HOSPITAL   *
      *             (SCH) ADJUSTMENT FOR YEARS 2006-2008        *
      *             EXISTING PARAGRAPHS WITH NEW LOGIC:         *
      *               - 5550-CALC-STANDARD                      *
      *               - 6550-CALC-STANDARD                      *
      *               - 5550-CALC-GJK                           *
      *               - 6550-CALC-GJK                           *
      *               - 7550-CALC-GJK                           *
      *               - 5550-SCH-ADJ                            *
      *               - 6550-SCH-ADJ                            *
      *               - 7550-SCH-ADJ                            *
      *                                                         *
      * 09/17/09- CREATE VERSION 2009.4.1 (OCTOBER 2009)        *
      * 2009.4.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (296 TOTAL APC CHANGES)                     *
      *                                                         *
      * 10/13/09- CREATE VERSION 2010.1.0 (JANUARY 2010)        *
      * 2010.1.0  - ADD 9000- SECTION AND PERFORM               *
      *           - ADDED CAL-VERSION9; UPDATED W-STORAGE-REF   *
      *                                                         *
      * 11/13/09- MAKE UPDATES FOR CY 2010 VERSION 2010.1.0     *
      * 2010.1.0  - CBSA RURAL FLOOR ASSIGNMENTS                *
      *             9120-FLOOR-2010                             *
      *           - SECTION 401 HOSPITAL ASSIGNMENTS            *
      *             9120-SEC401-2010                            *
      *           - INPATIENT DAILY COINSURANCE LIMIT: $1,100   *
      *             H-IP-LIMIT                                  *
      *           - RURAL FLOOR BUDGET NEUTRALITY TABLE SEARCH  *
      *             9220-APPLY-SSRFBN, 9225-FIND-SSRFBN         *
      *           - BLOOD DEDUCTIBLE HCPCS LIST & TABLE SEARCH  *
      *             9655-SET-BD-HCPCS-FLAG,                     *
      *             W-2010-BLOOD-APC-FILLS,                     *
      *             W-2010-BLOOD-APC-TABLE                      *
      *           - OUTLIER THRESHOLD: $2,175                   *
      *             9600-ADJ-CHRG-OUTL                          *
      *           - QUALITY RATIO: 0.980, 9180-REDUCE-APC-PYMT  *
      *           - DEVICE REDUCTION COPYBOOK & TABLE SEARCH    *
      *             9550-DEVICE-REDUC, 9550-DEVICE-COMPUTE,     *
      *             DEVRED10                                    *
      *           - MENTAL HEALTH HCPCS COPYBOOK & TABLE SEARCH *
      *             9150-INIT, OPPSMH10                         *
      *           - PARTIAL HOSPITALIZATION (PHP) HCPCS COPYBOOK*
      *             & TABLE SEARCH, 9150-INIT, OPPSPH10         *
      *                                                         *
      * 11/13/09- MAKE UPDATES FOR CY 2010 VERSION 2010.1.0     *
      * 2010.1.0  - PASS-THROUGH RADIOPHARM HCPCS & NUCLEAR     *
      *             MEDICINE APC OFFSETS                        *
      *             BASEPTRH, BASEPTRO, OPPSPTRH, OPPSPTRO      *
      *           - PASS-THROUGH CONTRAST AGENT HCPCS &         *
      *             PROCEDURE APC OFFSETS COPYBOOKS             *
      *             BASEPTCH, BASEPTCO, OPPSPTCH, OPPSPTCO      *
      *                                                         *
      * 11/14/09- MAKE UPDATES FOR CY 2010 VERSION 2010.1.0     *
      * 2010.1.0  - STATE-SPECIFIC RURAL FLOOR BUDGET           *
      *             NEUTRALITY TABLE: ADDED YEAR (10) TO        *
      *             COPYBOOK VARIABLE NAMES (SSRFBN10) &        *
      *             UPDATED VARIABLES IN LOGIC ACCORDINGLY      *
      *             9220-APPLY-SSRFBN, 9225-FIND-SSRFBN         *
      *           - CBSA WAGE INDEX HISTORY TABLE (OPPSWNXC)    *
      *           - APC RATE HISTORY TABLE (OPPSAPCS)           *
      *                                                         *
      * 11/15/09- MAKE UPDATES FOR CY 2010 VERSION 2010.1.0     *
      * 2010.1.0  - ENSURE BRACHYTHERAPY SERVICES (SI = U) ARE  *
      *             GIVEN REGULAR APC PAYMENT LIKE SI G, K, & R *
      *             NO LONGER PAID AT COST                      *
      *             9550-CALC-STANDARD, 9550-CALC-GJK           *
      *           - ENSURE THERAPEUTIC RADIOPHARM SERVICES      *
      *             (PREVIOUSLY SI = H, NOW SI = K) ARE GIVEN   *
      *             REGULAR APC PAYMENT LIKE SI G, K, & R       *
      *             NO LONGER PAID AT COST                      *
      *             9550-CALC-STANDARD, 9550-CALC-GJK           *
      *           - REMOVE LOGIC FOR PAID-AT-COST RADIOPHARMS   *
      *             9150-INIT                                   *
      *             9660-SET-RADIOPH-APC-FLAG                   *
      *             9550-CALC-STANDARD                          *
      *             9555-CALC-H-TOT                             *
      *             9555-CALC-H-STANDARD                        *
      *                                                         *
      * 11/16/09  - CREATE TABLES & LOGIC FOR NEW PASS-THROUGH  *
      * 2010.1.0    CONTRAST AGENT LOGIC                        *
      *                                                         *
      *             NEW VARIABLES:                              *
      *             - PTCA-CLAIM-FLAG                           *
      *             - PTCA-LINE-FLAG                            *
      *             - W-PTCA-LINE-HCPCS                         *
      *             - W-PTCA-CHRG-RATE                          *
      *             - W-PTCA-LINE-OFFSET                        *
      *             - W-CAPROC-LINE-APC                         *
      *             - W-CAPROC-SUB                              *
      *             - W-CAPROC-UNIT-CNT                         *
      *             - W-CAPROC-OFFSET                           *
      *             - W-CAPROC-KEY                              *
      *             - H-PTCA-LIDOS                              *
      *                                                         *
      *             NEW WORKING-STORAGE TABLES:                 *
      *             - W-PTCA-DAY-TBL                            *
      *             - W-CAPROC-APC-TBL                          *
      *                                                         *
      *             EXISTING PARAGRAPHS AFFECTED:               *
      *             - 9000-PROCESS-MAIN-NEW                     *
      *             - 9100-INIT                                 *
      *             - 9125-INIT                                 *
      *             - 9150-INIT                                 *
      *             - 9550-CALC-STANDARD                        *
      *                                                         *
      *             NEW PARAGRAPHS:                             *
      *             - 9130-LOAD-PTCA-DAY-TABLE...(& CALLED PARS)*
      *             - 9168-PROCESS-PTCA-PROC...(& CALLED PARS)  *
      *             - 9396-TOTAL-DAY-PTCA-OFFS                  *
      *             - 9550-PTCA-OFFSET                          *
      *             - 9681-SET-PTCA-LINE-FLAG                   *
      *                                                         *
      * 11/17/09  - MAKE BRACHYTHERAPY SERVICES (SI=U) ELIGIBLE *
      * 2010.1.0    FOR OUTLIER PAYMENT, 9600-ADJ-CHRG-OUTL     *
      *           - MAKE BRACHYTHERAPY SERVICES (SI=U) ELIGIBLE *
      *             FOR SOLE COMMUNITY HOSPITAL (SCH)           *
      *             ADJUSTMENT, 9550-SCH-ADJ, 9550-CALC-GJK     *
      *                                                         *
      * 12/02/09- CREATE VERSION 2010.1.1 (JANUARY 2010)        *
      * 2010.1.1  - TEST AND CORRECT NEW PASS-THROUGH CONTRAST  *
      *             AGENT OFFSET LOGIC                          *
      *           - REVISE LOGIC IN PARAGRAPH 9550-PTCA-OFFSET  *
      *             TO SET OFFSET PAYMENT TO $0 WHEN THE OFFSET *
      *             AMOUNT IS GREATER THAN THE PAYMENT          *
      * 12/03/09  - REVISED LOGIC IN 9396-TOTAL-DAY-PTCA-OFFS   *
      * 2010.1.1    TO LIMIT PERFORM LOOPS TO THE VALUE OF      *
      *             W-CAPROC-UNIT-CNT INSTEAD OF W-CAPROC-INDX  *
      *           - CORRECT BRACHYTHERAPY STATUS INDICATOR      *
      *             IN PAR. 9550-CALC-STANDARD.  CHANGED FROM   *
      *             'U' TO ' U'                                 *
      *                                                         *
      * 12/16/09- CREATE VERSION 2010.1.2 (JANUARY 2010)        *
      * 2010.1.2  - ADD SIS ELIGIBLE FOR OUTLIER PAYMENT TO     *
      *             LOGIC THAT DISTRIBUTES PACKAGED CHARGES TO  *
      *             PAYABLE LINES.                              *
      *             CY 2009: 8600-ADJ-CHRG-OUTL, SI R           *
      *             CY 2010: 9600-ADJ-CHRG-OUTL, SIS R AND U    *
      *           - UPDATE APC TABLE WITH ASP DRUGS             *
      *             (296 TOTAL APC UPDATE RECORDS)              *
      * 12/18/09  - ADD SIS ELIGIBLE FOR OUTLIER PAYMENT TO     *
      * 2010.1.2    LOGIC THAT SUMS OUTLIER ELIGIBLE LINE PMTS  *
      *             CY 2009: 8500-ADJ-CHRGS, SI R               *
      *             CY 2010: 9500-ADJ-CHRGS, SIS R AND U        *
      * 12/22/09  - UPDATE APC TABLE WITH ASP DRUGS             *
      * 2010.1.2    (296 TOTAL APC UPDATE RECORDS - CORRECTION) *
      *                                                         *
      * 12/30/09- CREATE VERSION 2010.2.0 (APRIL 2010)          *
      * 2010.2.0  - ADD LOGIC TO CATCH DIVISION BY ZERO ERROR   *
      *             IN PARAGRAPHS 8550-PTRADIO-OFFSET,          *
      *             9550-PTRADIO-OFFSET, & 9550-PTCA-OFFSET     *
      *             (NOTE: FISS EDITS REQUIRE CHARGES TO BE     *
      *              > $0, SO THIS CODE IS PRECAUTIONARY, NOT   *
      *              NECESSARY FOR FISS.)                       *
      *                                                         *
      * 03/19/10- - UPDATED APC TABLE WITH APRIL 2010 ASP DRUG  *
      * 2010.2.0    RATES (274 TOTAL RECORD CHANGES)            *
      *                                                         *
      * 04/03/10- CREATE VERSION 2010.2.1 (ACA RELEASE)         *
      * 2010.2.1    ACA = AFFORDABLE CARE ACT (HEALTH REFORM)   *
      *           - UPDATED APC TABLE WITH JANUARY 2010 AND     *
      *             APRIL 2010 ASP DRUG RATES (427 & 423 RECORD *
      *             CHANGES RESPECTIVELY) REVISED IN RESPONSE   *
      *             TO THE ACA                                  *
      * 04/04/10  - CREATED NEW PT RADIO OFFSET HISTORY TABLE   *
      * 2010.2.1    (NUCLEAR MEDICINE APCS) TO REFLECT ACA      *
      *             CHANGES - SAME TABLE NAME, EFFECTIVE        *
      *             RETROACTIVELY 1/1/10                        *
      *             (OPPSPTRO)                                  *
      *           - CREATED NEW DEVICE REDUCTION (FB/FC) TABLE  *
      *             TO REFLECT ACA CHANGES - SAME TABLE NAME,   *
      *             EFFECTIVE RETROACTIVELY 1/1/10              *
      *             (DEVRED10)                                  *
      *           - CREATED NEW PASS-THROUGH CONTRAST AGENT     *
      *             OFFSET TABLE TO REFLECT ACA CHANGES - SAME  *
      *             TABLE NAME, EFFECTIVE RETROACTIVELY 1/1/10  *
      *             (OPPSPTCO)                                  *
      *                                                         *
      * 05/06/10- CREATE VERSION 2010.3.0 (JULY 2010)           *
      * 2010.3.0  - UPDATED VERSION AND QUARTER NUMBERS IN PGM  *
      * 05/13/10  - UPDATED BASEWNXC & OPPSWNXC WITH RECORDS    *
      * 2010.3.0    EFFECTIVE 07/01/2010 (CORRESPOND TO IPPS    *
      *             RECORDS EFFECTIVE 04/01/2010) - DUE TO IPPS *
      *             SECTION 508 POLICY EXTENSION MANDATED BY    *
      *             2010 ACA                                    *
      *           - CREATED NEW STATE-SPECIFIC RURAL FLOOR      *
      *             BUDGET NEUTRALITY FACTOR TABLE EFFECTIVE    *
      *             07/01/2010 (SSRFB10B) - INCLUDES CORRECTED  *
      *             FLORIDA FACTOR (DUE TO SECTION 508 EXT.)    *
      *           - ADDED NEW LOGIC AND PARAGRAPHS TO APPLY     *
      *             FACTORS FROM SSRFB10B TO CLAIMS DISCHARGED  *
      *             AFTER 6/30/2010                             *
      *             AFFECTED PARAGRAPH: 9200-CALC-WAGEINDX      *
      *             NEW PARAGRAPHS: 9226-APPLY-SSRFBN-2ND-HALF  *
      *                             9227-FIND-SSRFBN-2ND-HALF   *
      *           - CORRECTED FLOOR LOGIC FOR CBSA 33           *
      *             AFFECTED PARAGRAPH: 9120-FLOOR-2010         *
      *                                                         *
      * 05/20/10- UPDATE TABLES TO REFLECT CORRECTIONS TO THE   *
      * 2010.3.0    ACA RATE UPDATES (TABLES COPIED FROM VERSION*
      *             2010.2.2); ERROR DUE TO INCORRECT BUDGET    *
      *             NEUTRALITY FACTOR USED TO CALCULATE RATES   *
      *             IN VERSION 2010.2.1                         *
      *             VERSION 2010.2.2 REPLACED BY THIS VERSION   *
      *           - UPDATED APC TABLE WITH JANUARY 2010 AND     *
      *             APRIL 2010 ASP DRUG RATES (427 & 423 RECORD *
      *             CHANGES RESPECTIVELY) REVISED IN RESPONSE   *
      *             TO THE ACA                                  *
      *           - CREATED NEW PT RADIO OFFSET HISTORY TABLE   *
      *             (NUCLEAR MEDICINE APCS) TO REFLECT ACA      *
      *             CHANGES - SAME TABLE NAME, EFFECTIVE        *
      *             RETROACTIVELY 1/1/10                        *
      *             (OPPSPTRO)                                  *
      *           - CREATED NEW DEVICE REDUCTION (FB/FC) TABLE  *
      *             TO REFLECT ACA CHANGES - SAME TABLE NAME,   *
      *             EFFECTIVE RETROACTIVELY 1/1/10              *
      *             (DEVRED10)                                  *
      *           - CREATED NEW PASS-THROUGH CONTRAST AGENT     *
      *             OFFSET TABLE TO REFLECT ACA CHANGES - SAME  *
      *             TABLE NAME, EFFECTIVE RETROACTIVELY 1/1/10  *
      *             (OPPSPTCO)                                  *
      *                                                         *
      * 06/17/10- CREATE VERSION 2010.3.1 (JULY 2010)           *
      * 2010.3.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (276 TOTAL APC RECORDS ADDED)               *
      *           - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      *                                                         *
      * 06/22/10- CREATE VERSION 2010.3.2 (JULY 2010)           *
      * 2010.3.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (276 TOTAL APC RECORDS ADDED)               *
      *             CORRERCTION TO PREVIOUS TABLE - RECORD FOR  *
      *             APC 01310 ADDED, RECORD FOR APC 01239       *
      *             DELETED.                                    *
      *           - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      *                                                         *
      * 08/02/10- CREATE VERSION 2010.4.0 (OCTOBER 2010)        *
      * THRU      - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      * 08/13/10  - UPDATED CAL-VERSION9 WITH NEW QTR #         *
      * 2010.4.0  - START CODING REVISED PASS-THROUGH DEVICE    *
      *             OFFSET LOGIC FOR CY 2010 - DEVICE C1749 IS  *
      *             NEW EFFECTIVE 10/01/2010                    *
      *                                                         *
      *             NEW COPYBOOK:                               *
      *             - OPPSPTDO                                  *
      *                                                         *
      *             NEW VARIABLES:                              *
      *             - PTDO-CLAIM-FLAG                           *
      *             - PTDO-LINE-FLAG                            *
      *             - W-PTDO-LINE-HCPCS                         *
      *             - W-PTDO-CHRG-RATE                          *
      *             - W-PTDO-LINE-OFFSETET                      *
      *             - W-PTDO-EOF-SWITCH                         *
      *             - W-DOPROC-LINE-APC                         *
      *             - W-DOPROC-SUB                              *
      *             - W-DOPROC-UNITS                            *
      *             - W-DOPROC-OFFSET                           *
      *             - W-DOPROC-KEY                              *
      *             - H-PTDO-CHRGUNIT                           *
      *             - H-PTDO-ASSOC-HCPCS-CTR                    *
      *             - H-PTDO-PROC-KEY                           *
      *                                                         *
      *             NEW WORKING-STORAGE TABLES:                 *
      *             - W-PTDO-HCPCS-TBL                          *
      *             - W-PTDO-PROC-TBL                           *
      *             - W-PTDO-ASSOC-HCPCS-TBL                    *
      *                                                         *
      *             EXISTING PARAGRAPHS AFFECTED:               *
      *             - 9000-PROCESS-MAIN-NEW                     *
      *             - 9100-INIT                                 *
      *             - 9125-INIT                                 *
      *             - 9150-INIT                                 *
      *             - 9550-CALC-STANDARD                        *
      *             - 9555-CALC-H-STANDARD                      *
      *                                                         *
      *             NEW PARAGRAPHS:                             *
      *             - 9132-LOAD-PTDO-HCPCS-TBL                  *
      *             - 9132-ADD-ENTRY                            *
      *             - 9132-STAGE-PTDO-HCPCS-ENTRY               *
      *             - 9169-PROCESS-PTDO-PROC                    *
      *             - 9169-LOAD-ASSOC-PTD-HCPCS                 *
      *             - 9169-COUNT-PTDO-MAPPINGS                  *
      *             - 9169-LOAD-PTDO-PROC-TABLE                 *
      *             - 9169-STAGE-PTDO-PROC-ENTRY                *
      *             - 9397-PTDO-MAPPINGS-1                      *
      *             - 9397-PTDO-MAPPINGS-2                      *
      *             - 9556-CALC-PTDO-OFFSET                     *
      *             - 9682-SET-PTDO-LINE-FLAG                   *
      *                                                         *
      *             DISABLED/DELETED PARAGRAPHS:                *
      *             - 9160-TOTAL-OFFSET                         *
      *             - 9161-TOTAL-OFFSET-AMT                     *
      *             - 9555-CALC-H-TOT                           *
      *             - 9700-CALC-H-OFFSET                        *
      *                                                         *
      * 08/12/10- - UPDATE PARAGRAPHS 9665-SET-PTD-LINE-FLAG &  *
      * 2010.4.0    9670-SET-PTD-PROC-FLAG TO PROCESS NEW PASS- *
      *             THROUGH DEVICE & CORRESPONDING PROCEDURES   *
      *           - UPDATE APC TABLE WITH THE NEW PASS-THROUGH  *
      *             DEVICE APC                                  *
      *           - CREATE, UPDATE OPPSPTDO TABLE FOR REVISED   *
      *             PASS-THROUGH DEVICE LOGIC                   *
      *                                                         *
      * 09/16/10- CREATE VERSION 2010.4.1 (OCTOBER 2010)        *
      * 2010.4.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (273 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      *                                                         *
      * 11/03/10- CREATE VERSION 2011.1.0 (JANUARY 2011)        *
      * THRU      - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      * 11/16/10  - ADDED CAL-VERSION10 FOR CY 2011 CALL        *
      * 2011.1.0  - UPDATED PARAGRAPH NAMES TO REFLECT 10000    *
      *             SERIES                                      *
      *           - UPDATED BASEAPCS & OPPSAPCS,                *
      *                     BASEPTCH & OPPSPTCH,                *
      *                     BASEPTCO & OPPSPTCO,                *
      *                     BASEPTRO & OPPSPTRO,                *
      *                     BASEWNXC & OPPSWNXC, AND            *
      *                     DEVRED11 TABLES                     *
      *           - ADDED STATE RURAL FLOOR LOGIC FOR CY 2011   *
      *             PARAGRAPH: 10120-FLOOR-2011                 *
      *           - ADDED SECTION 401 HOSPITAL LOGIC FOR CY 2011*
      *             PARAGRAPH: 10120-SEC401-2011                *
      *           - MODIFIED LOGIC IN PARAGRAPHS 10125-INIT &   *
      *             10550-PHP-PMT-FOR-OUTL TO ACCOMODATE NEW    *
      *             APCS 00175 & 00176 FOR HOSPITAL BASED PHP   *
      *             LINES.  SET PAYMENT TO APC 00176'S RATE FOR *
      *             HOSPITAL PHP OUTLIER CALCULATIONS.          *
      *           - CHANGED H-IP-LIMIT TO 1132                  *
      *           - CHANGED OUTLIER THRESHOLD TO 2025           *
      *           - ADDED SI = U (BRACHY) LINES TO QUALITY      *
      *             REDUCTION LOGIC FOR 2010 AND 2011           *
      *                                                         *
      * 12/16/10- CREATE VERSION 2011.1.1 (JANUARY 2011)        *
      * 2011.1.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (331 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 12/22/10- CREATE VERSION 2011.1.2 (JANUARY 2011)        *
      * 2011.1.2  - UPDATED APC TABLE WITH REVISED ASP TABLE    *
      *             (331 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 03/17/11- CREATE VERSION 2011.2.0 (APRIL 2011)          *
      * 2011.2.0  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (259 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF & CAL-VERSION10       *
      *                                                         *
      * 04/11/11- CREATE VERSION 2011.2.1 (APRIL 2011)          *
      * 2011.2.1  - ADDED LOGIC TO PREVENT LINES WITH A PAYMENT *
      *             ADJ. FLAG OF 9 FROM RECEIVING CO-INSURANCE  *
      *             AND DEDUCTIBLE, AND LINES WITH A PAF OF 10  *
      *             FROM RECEIVING CO-INSURANCE TO IMPLEMENT    *
      *             THE PREVENTIVE SERVICES WAIVER FOR CY 2011. *
      *                                                         *
      *             AFFECTED PARAGRAPHS:                        *
      *             - 10150-INIT: PAFS 9 & 10 ADDED TO LIST OF  *
      *               VALID PAFS                                *
      *             - 10560-CALC-BENE-DEDUCT: LINES WITH PAF 9  *
      *               DIVERTED FROM DEDUCTIBLE CALC             *
      *             - 10550-CALC-STANDARD: CO-INSURANCE AMOUNTS *
      *               (NAT, MIN, MAX, & RED) SET TO $0 &        *
      *               REIMBURSEMENT CALC MODIFIED FOR LINES     *
      *               WITH A PAF = 9 OR 10                      *
      *                                                         *
      * 05/06/11- CREATE VERSION 2011.3.0 (JULY 2011)           *
      * 2011.3.0  - UPDATED W-STORAGE-REF & CAL-VERSION10       *
      * 05/09/11  - ADDED LOGIC TO PREVENT BILL TYPE 14X FROM   *
      *             RECEIVING THE SOLE COMMUNITY HOSPITAL (SCH) *
      *             7.1% ADD-ON FOR YEARS 2006 - 2011.  BECAUSE *
      *             PRICER DOES NOT RECEIVE THE BILL TYPE FROM  *
      *             THE IOCE, PRICER IDENTIFIES BILL TYPE 14X   *
      *             AS CLAIMS WHERE ALL LINES HAVE A HCPCS      *
      *             IN THE RANGE OF 80000 - 89999, INCLUSIVE =  *
      *             LAB CODES.                                  *
      *                                                         *
      *             NEW VARIABLE: BILL14X-FLAG                  *
      *                                                         *
      *             AFFECTED PARAGRAPHS:                        *
      *             - 5100-INIT                                 *
      *             - 6100-INIT                                 *
      *             - 7100-INIT                                 *
      *             - 8100-INIT                                 *
      *             - 9100-INIT                                 *
      *             - 10100-INIT                                *
      *                                                         *
      *             - 5125-INIT                                 *
      *             - 6125-INIT                                 *
      *             - 7125-INIT                                 *
      *             - 8125-INIT                                 *
      *             - 9125-INIT                                 *
      *             - 10125-INIT                                *
      *                                                         *
      *             - 5550-SCH-ADJ                              *
      *             - 6550-SCH-ADJ                              *
      *             - 7550-SCH-ADJ                              *
      *             - 8550-SCH-ADJ                              *
      *             - 9550-SCH-ADJ                              *
      *             - 10550-SCH-ADJ                             *
      *                                                         *
      * 06/17/11- CREATE VERSION 2011.3.1 (JULY 2011)           *
      * 2011.3.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (304 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 08/09/11- CREATE VERSION 2011.4.0 (OCTOBER 2011)        *
      * 2011.4.0  - UPDATED APC TABLE WITH TWO NEW NON-ASP APCS *
      *             (2 TOTAL APC RECORDS ADDED/UPDATED)         *
      *           - UPDATED W-STORAGE-REF & CAL-VERSION10       *
      *           - UPDATED PT DEVICE OFFSET HISTORY TABLE      *
      *             (OPPSPTDO) WITH TWO NEW DEVICES (C1830 &    *
      *             C1840)                                      *
      *                                                         *
      * 08/15/11- - UPDATE PARAGRAPHS 10665-SET-PTD-LINE-FLAG & *
      * 2011.4.0    10670-SET-PTD-PROC-FLAG TO PROCESS NEW PASS-*
      *             THROUGH DEVICES & CORRESPONDING PROCEDURES  *
      *                                                         *
      * 09/15/11- CREATE VERSION 2011.4.1 (OCTOBER 2011)        *
      * 2011.4.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (262 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 10/25/11- CREATE VERSION 2012.1.0 (JANUARY 2012)        *
      * THRU      - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      * 11/07/11  - ADDED CAL-VERSION11 FOR CY 2012 CALL        *
      * 2012.1.0  - ADDED NEW 11000 SECTION FOR CY 2012 LOGIC   *
      *           - UPDATED INPATIENT DAILY COIN. LIMIT TO 1156 *
      *           - UPDATED OUTPATIENT THRESHOLD TO 1900        *
      *           - ADDED STATE RURAL FLOOR LOGIC FOR CY 2012   *
      *             PARAGRAPH: 11120-FLOOR-2012                 *
      *           - ADDED SECTION 401 HOSPITAL LOGIC FOR CY 2012*
      *             PARAGRAPH: 11120-SEC401-2012                *
      *           - NO STATE-SPECIFIC RFBN FOR CY 2012; LOGIC   *
      *             REMAINS DISABLED                            *
      *           - UPDATED BASEAPCS & OPPSAPCS,                *
      *                     BASEPTCH & OPPSPTCH,                *
      *                     BASEPTCO & OPPSPTCO,                *
      *                     BASEPTDO & OPPSPTDO,                *
      *                     BASEPTRH & OPPSPTRH,                *
      *                     BASEPTRO & OPPSPTRO,                *
      *                     BASEWNXC & OPPSWNXC,                *
      *                     DEVRED12,                           *
      *                     OPPSMH12, AND                       *
      *                     W-2012-BLOOD-APC-TABLE              *
      *           - UPDATED PT DEVICE OFFSET LOGIC IN PARAGRAPH *
      *             11665-SET-PTD-LINE-FLAG & PARAGRAPH         *
      *             11670-SET-PTD-PROC-FLAG                     *
      *           - UPDATED LIST OF BLOOD DEDUCTIBLE HCPCS IN   *
      *             PARAGRAPH 11655-SET-BD-HCPCS-FLAG TO        *
      *             REFLECT CY 2012 ORDER OF LOW TO HIGH APC    *
      *             PAYMENT RATE                                *
      *           - MODIFIED CY 2011 & CY 2012 LOGIC TO APPLY   *
      *             PHP CAP TO PHP CMHC LINES (APC 173) ONLY,   *
      *             NOT TO PHP HOSPITAL LINES (PREVIOUSLY APC   *
      *             176) FOR THE OUTLIER CALCULATION PER        *
      *             DIRECTION FROM POLICY. PARAGRAPHS AFFECTED: *
      *             - 10550-PHP-PMT-FOR-OUTL                    *
      *             - 10600-ADJ-CHRG-OUTL                       *
      *             - 11550-PHP-PMT-FOR-OUTL                    *
      *             - 11600-ADJ-CHRG-OUTL                       *
      *           - ADDED COPY STATEMENTS FOR TABLES):          *
      *             - OPPSMH12                                  *
      *             - DEVRED12                                  *
      *           - REFERENCED 2012 MH TABLE IN PARAGRAPH       *
      *             11150-INIT                                  *
      *           - REFERENCED 2012 DEVICE REDUCTION TABLE IN   *
      *             PARAGRAPHS 11550-DEVICE-REDUC &             *
      *             11550-DEVICE-COMPUTE                        *
      *           - NO CHANGE TO PHP HCPCS LIST PER POLICY      *
      *                                                         *
      * 11/15/11- REVISED DEVRED12 TABLE                        *
      *                                                         *
      * 12/09/11- CREATE VERSION 2012.1.1 (JANUARY 2012)        *
      * THRU      - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      * 12/20/11  - UPDATED ALL RATE TABLES, EXCLUDING THE      *
      * 2012.1.1    CBSA WAGE INDEX HISTORY TABLE, TO CORRECT   *
      *             VALUES PER INSTRUCTIONS FROM POLICY -       *
      *             SOURCE OF ERROR WAS INCORRECT MEDIAN COST   *
      *             UPDATED BASEAPCS & OPPSAPCS,                *
      *                     BASEPTCO & OPPSPTCO,                *
      *                     BASEPTDO & OPPSPTDO,                *
      *                     BASEPTRO & OPPSPTRO,                *
      *                     DEVRED12                            *
      *           - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (323 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - CHANGED THE OUTLIER THRESHOLD FROM 1900     *
      *             TO 2025 - ALSO RELATED TO MEDIAN COST ERROR *
      *           - REVISED PASS-THROUGH DEVICE OFFSET LOGIC TO *
      *             ACCOMMODATE PT DEVICES THAT HAVE MULTIPLE   *
      *             PROCEDURE PAIRINGS WITH DIFFERENT EFFECTIVE *
      *             & TERMINATION DATES FOR CY 2010 - CY 2012.  *
      *             PARAGRAPHS AFFECTED:                        *
      *             - 9682-SET-PTDO-LINE-FLAG  (CY 2010)        *
      *             - 10682-SET-PTDO-LINE-FLAG (CY 2011)        *
      *             - 11682-SET-PTDO-LINE-FLAG (CY 2012)        *
      *           - REVISED TERMINATION DATE COMPARISON LOGIC   *
      *             FOR PASS-THROUGH OFFSETS.  THE TERMINATION  *
      *             DATE IN THE OFFSET TABLES IS THE LAST DAY   *
      *             THE RECORD IS VALID, SO A VALID DATE OF     *
      *             SERVICE CAN BE EQUAL TO THE TERMINATION     *
      *             DATE.  LOGIC REVISED TO INCLUDE TERMINATION *
      *             DATE AS A VALID DATE OF SERVICE FOR         *
      *             CY 2009 - CY 2012.                          *
      *                                                         *
      *             PARAGRAPHS AFFECTED:                        *
      *                                                         *
      *             PASS-THROUGH DEVICE OFFSET                  *
      *             -9169-PROCESS-PTDO-PROC      (CY 2010)      *
      *             -10169-PROCESS-PTDO-PROC     (CY 2011)      *
      *             -11169-PROCESS-PTDO-PROC     (CY 2012)      *
      *                                                         *
      *             PASS-THROUGH RADIOPHARM OFFSET              *
      *             -8680-SET-PTRADIO-LINE-FLAG  (CY 2009)      *
      *             -9680-SET-PTRADIO-LINE-FLAG  (CY 2010)      *
      *             -10680-SET-PTRADIO-LINE-FLAG (CY 2011)      *
      *             -11680-SET-PTRADIO-LINE-FLAG (CY 2012)      *
      *                                                         *
      *             PASS-THROUGH CONTRAST AGENT OFFSET          *
      *             -9681-SET-PTCA-LINE-FLAG     (CY 2010)      *
      *             -10681-SET-PTCA-LINE-FLAG    (CY 2011)      *
      *             -10681-SET-PTCA-LINE-FLAG    (CY 2012)      *
      *                                                         *
      * 02/03/12- CREATE VERSION 2012.2.0 (APRIL 2012)          *
      * THRU      - UPDATED W-STORAGE-REF & CAL-VERSION11       *
      * 02/14/12  - CHANGE HCPCS A9584'S EFFECTIVE DATE FROM    *
      * 2012.2.0    07/01/2011 TO 01/01/2012 IN TABLES          *
      *             BASEPTRH AND OPPSPTRH (PASS-THROUGH RADIO)  *
      *           - CREATE NEW TABLES FOR CORRECTED RATES       *
      *             EFFECTIVE 01/01/2012                        *
      *             - BASEPTCO, OPPSPTCO (PT CONTRAST OFFSET)   *
      *             - BASEPTRO, OPPSPTRO (PT RADIOPHARM OFFSET) *
      *             - DEVRED12 (2012 FB/FC DEVICE REDUCTION)    *
      *           - ADD BILL TYPE VARIABLE (L-TYPE-OF-BILL) TO  *
      *             LINKAGE SECTION                             *
      *           - CHANGED LOGIC THAT PREVENTS BILL TYPE 14X   *
      *             FROM RECEIVING THE SOLE COMMUNITY HOSPITAL  *
      *             (SCH) 7.1% ADD-ON FOR YEARS 2006 - 2012 TO  *
      *             USE THE TYPE OF BILL FROM THE CLAIM INSTEAD *
      *             OF IDENTIFYING BILL TYPE 14X AS CLAIMS      *
      *             WHERE ALL LINES HAVE A HCPCS IN THE RANGE   *
      *             OF 80000 - 89999, INCLUSIVE (LAB CODES)     *
      *                                                         *
      *             DELETED VARIABLE: BILL14X-FLAG              *
      *             NEW CONDITION NAME: BILL-TYPE-14X           *
      *             (FOR VARIABLE L-TYPE-OF-BILL)               *
      *                                                         *
      *             AFFECTED PARAGRAPHS:                        *
      *             - 5100-INIT                                 *
      *             - 6100-INIT                                 *
      *             - 7100-INIT                                 *
      *             - 8100-INIT                                 *
      *             - 9100-INIT                                 *
      *             - 10100-INIT                                *
      *             - 11100-INIT                                *
      *                                                         *
      *             - 5125-INIT                                 *
      *             - 6125-INIT                                 *
      *             - 7125-INIT                                 *
      *             - 8125-INIT                                 *
      *             - 9125-INIT                                 *
      *             - 10125-INIT                                *
      *             - 11125-INIT                                *
      *                                                         *
      *             - 5550-SCH-ADJ                              *
      *             - 6550-SCH-ADJ                              *
      *             - 7550-SCH-ADJ                              *
      *             - 8550-SCH-ADJ                              *
      *             - 9550-SCH-ADJ                              *
      *             - 10550-SCH-ADJ                             *
      *             - 11550-SCH-ADJ                             *
      *           - MOVE LOCATION OF L-TYPE-OF-BILL VARIABLE    *
      *             TO MATCH FISS INTERFACE                     *
      *                                                         *
      * 03/15/12- CREATE VERSION 2012.2.1 (APRIL 2012)          *
      * 2012.2.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (269 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 05/10/12- CREATE VERSION 2012.3.0 (JULY 2012)           *
      * THRU      - UPDATE W-STORAGE-REF & CAL-VERSION11        *
      * 05/15/12  - CREATE NEW TABLES FOR CORRECTED RATES       *
      * 2012.3.0    EFFECTIVE RETROACTIVE TO 01/01/2012         *
      *             - BASEPTCO, OPPSPTCO (PT CONTRAST OFFSET)   *
      *             - BASEPTRO, OPPSPTRO (PT RADIOPHARM OFFSET) *
      *             - DEVRED12 (2012 FB/FC DEVICE REDUCTION)    *
      *             - BASEPTDO, OPPSPTDO (PT DEVICE OFFSET)     *
      *           - UPDATE APC TABLE (NON-ASP) WITH CORRECTED   *
      *             RATES EFFECTIVE 1/1/12 & JULY 2012 CHANGES  *
      *             (428 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATE PT DEVICE OFFSET PROCEDURE PAIRINGS  *
      *             LOGIC (PARAGRAPH 11670-SET-PTD-PROC-FLAG)   *
      * 05/15/12  - CREATE NEW BASEPTDO & OPPSPTDO TABLES DUE   *
      *             TO CORRECTION                               *
      *                                                         *
      * 06/15/12- CREATE VERSION 2012.3.1 (JULY 2012)           *
      * 2012.3.1  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (269 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      *                                                         *
      * 09/13/12- CREATE VERSION 2012.4.0 (OCTOBER 2012)        *
      * 2012.4.0  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (276 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *           - UPDATED CAL-VERSION11                       *
      *           - UPDATED APC TABLE WITH THREE CORRECTION     *
      *             RECORDS TO DELETE APCS 01362 AND 01373      *
      *             (3 TOTAL APC RECORDS UPDATED)               *
      *                                                         *
      * 11/07/12- CREATE VERSION 2013.1.0 (JANUARY 2013)        *
      * THRU      - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      * 11/**/12  - ADDED CAL-VERSION12 FOR CY 2013 CALL        *
      * 2013.1.0  - ADDED NEW 12000 SECTION FOR CY 2013 LOGIC   *
      *           - UPDATED INPATIENT DAILY COIN. LIMIT TO 1184 *
      *           - HELD OUTPATIENT THRESHOLD AT 2025           *
      *           - ADDED STATE RURAL FLOOR LOGIC FOR CY 2013   *
      *             PARAGRAPH: 12120-FLOOR-2013                 *
      *           - ADDED SECTION 401 HOSPITAL LOGIC FOR CY 2013*
      *             PARAGRAPH: 12120-SEC401-2013                *
      *           - NO STATE-SPECIFIC RFBN FOR CY 2013; LOGIC   *
      *             REMAINS DISABLED                            *
      *           - HELD QUALITY RATIO AT 0.980                 *
      *             PARAGRAPH: 12180-REDUCE-APC-PYMT            *
      *           - UPDATED LIST OF BLOOD DEDUCTIBLE HCPCS IN   *
      *             PARAGRAPH 12655-SET-BD-HCPCS-FLAG TO        *
      *             REFLECT CY 2013 ORDER OF LOW TO HIGH APC    *
      *             PAYMENT RATE                                *
      *           - CREATED W-2013-BLOOD-APC-TABLE, ORDERING    *
      *             BLOOD DEDUCTIBLE HCPCS FROM LOW TO HIGH     *
      *             APC RATE                                    *
      *           - CHANGED REFERENCES TO W-2011-BLOOD-APC-TABLE*
      *             TO REFER TO W-2012-BLOOD-APC-TABLE IN       *
      *             PARAGRAPH 11150-INIT (CHANGE FOR CY 2012)   *
      *           - REFERENCED W-2013-BLOOD-APC-TABLE VARIABLES *
      *             IN PARAGRAPH 12150-INIT                     *
      *           - UPDATED PT DEVICE OFFSET LOGIC IN PARAGRAPH *
      *             12665-SET-PTD-LINE-FLAG & PARAGRAPH         *
      *             12670-SET-PTD-PROC-FLAG                     *
      *           - UPDATED BASEAPCS & OPPSAPCS,                *
      *                     BASEPTCO & OPPSPTCO,                *
      *                     BASEPTDO & OPPSPTDO,                *
      *                     BASEPTRO & OPPSPTRO,                *
      *                     BASEWNXC & OPPSWNXC                 *
      *           - NO CHANGE TO:                               *
      *                     BASEPTRH & OPPSPTRH,                *
      *                     BASEPTCH & OPPSPTCH                 *
      *           - CREATED DEVRED13,                           *
      *                     OPPSMH13,                           *
      *                     OPPSPH13                            *
      *           - ADDED COPY STATEMENTS FOR TABLES):          *
      *             - OPPSMH13                                  *
      *             - DEVRED13                                  *
      *             - OPPSPH13                                  *
      *           - REFERENCED 2013 MH TABLE IN PARAGRAPH       *
      *             12150-INIT                                  *
      *           - REFERENCED 2013 PHP TABLE IN PARAGRAPH      *
      *             12150-INIT                                  *
      *           - REFERENCED 2013 DEVICE REDUCTION TABLE IN   *
      *             PARAGRAPHS 12550-DEVICE-REDUC &             *
      *             12550-DEVICE-COMPUTE                        *
      *                                                         *
      * 12/13/12- CREATE VERSION 2013.1.1 (JANUARY 2013)        *
      * 2013.1.1  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (267 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 02/08/13- CREATE VERSION 2013.2.0 (APRIL 2013)          *
      * 2013.2.0  - UPDATED W-STORAGE-REF VALUE                 *
      *           - UPDATED CAL-VERSION12 VALUE                 *
      *           - ADDED STEREOTACTIC RADIOSURGERY (SRS)       *
      *             PAYMENT CAP POLICY LOGIC EFFECTIVE          *
      *             APRIL 1, 2013                               *
      *                                                         *
      *             AFFECTED PARAGRAPH:                         *
      *             - 12150-INIT                                *
      *                                                         *
      *             NEW PARAGRAPH:                              *
      *             - 12176-APPLY-SRS-CAP                       *
      *                                                         *
      * 03/14/13- CREATE VERSION 2013.2.1 (APRIL 2013)          *
      * 2013.2.1  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (267 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 06/12/13- CREATE VERSION 2013.3.0 (JULY 2013)           *
      * 2013.3.0  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (272 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 07/30/13- CREATE VERSION 2013.4.0 (OCT 2013)            *
      * 2013.4.0  - UPDATED APC TABLE - 1 TOTAL APC RECORD      *
      *           - UPDATED W-STORAGE-REF                       *
      *           - UPDATED CAL-VERSION12 VALUE                 *
      *           - UPDATED BASEAPCS & OPPSAPCS,                *
      *                     BASEPTDO & OPPSPTDO,                *
      *                     BASEPTRH & OPPSPTRH                 *
      *           - UPDATED PT DEVICE OFFSET LOGIC IN PARAGRAPH *
      *             12665-SET-PTD-LINE-FLAG & PARAGRAPH         *
      *             12670-SET-PTD-PROC-FLAG                     *
      *                                                         *
      * 09/12/13- CREATE VERSION 2013.4.1 (OCT 2013)            *
      * 2013.4.1  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (283 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *           - REVISED SECTION 401 HOSPITAL LOGIC TO REMOVE*
      *             PROVIDER 040118 AND ADD PROVIDER 290009     *
      *             PER 10/2/2012 IPPS FY 2013 CORRECTION NOTICE*
      *             AFFECTED PARAGRAPH: 12120-SEC401-2013       *
      *                                                         *
      * 10/17/13- CREATE BETA VERSION OF OPPSCAL FOR            *
      * BETA      JANUARY 2014 USING OPPSCAL VERSION 2013.4.1   *
      *           (FROM OCT 2013 RELEASE)                       *
      *           - ADDED L-DEVICE-CREDIT AS LAST ENTRY IN      *
      *             LINKAGE SECTION & TO PROCEDURE DIVISION     *
      *             USING STATEMENT                             *
      *                                                         *
      * 11/01/13- CREATE VERSION 2014.1.0 (JANUARY 2014)        *
      * THRU      - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      * 12/03/13  - ADDED CAL-VERSION13 FOR CY 2014 CALL        *
      * 2014.1.0  - ADDED NEW 13000 SECTION FOR CY 2014 LOGIC   *
      *           - ADDED STATUS INDICATOR 'J1' TO LIST OF      *
      *             VALID INDICATORS: PARAGRAPH 13150-INIT-EXIT *
      *           - REMOVED STATUS INDICATOR 'J1' FROM LIST OF  *
      *             VALID INDICATORS: PARAGRAPH 13150-INIT-EXIT *
      *             AS IOCE WILL NOT PASS THIS SI IN CY 2014    *
      *           - UPDATED INPATIENT DAILY COIN. LIMIT TO 1216 *
      *             (H-IP-LIMIT) PARAGRAPH 13100-INIT           *
      *           - HELD QUALITY RATIO AT 0.980 (LITERAL)       *
      *             PARAGRAPH 13180-REDUCE-APC-PYMT             *
      *           - UPDATED OUTPATIENT THRESHOLD TO 2900        *
      *             PARAGRAPH 13600-ADJ-CHRG-OUTL               *
      *           - ADDED STATE RURAL FLOOR LOGIC FOR CY 2014   *
      *             PARAGRAPH: 13120-FLOOR-2014                 *
      *           - NOTE: SECTION 401 HOSPITAL LOGIC NO LONGER  *
      *             CODED IN PRICER, WAGE INDEX CBSA IS         *
      *             ASSIGNED IN THE OPSF                        *
      *           - NO STATE-SPECIFIC RFBN FOR CY 2014; LOGIC   *
      *             REMAINS DISABLED                            *
      *             PARAGRAPH: 13180-REDUCE-APC-PYMT            *
      *           - CODED NEW LOGIC TO IMPLEMENT THE DEVICE     *
      *             CREDIT POLICY EFFECTIVE STARTING 1/1/14     *
      *                                                         *
      *             NEW TABLE (COPYBOOK):                       *
      *             - DEV-CREDIT14 (REPLACES DEV-REDUC##)       *
      *                                                         *
      *             NEW VARIABLES:                              *
      *             - H-TOT-DEVCR-PYMTS                         *
      *             - H-DEVCR-PYMT-RATE                         *
      *             - H-LINE-DEVCR-AMT                          *
      *                                                         *
      *             NEW PARAGRAPH:                              *
      *             - 13550-DEVICE-CREDIT                       *
      *                                                         *
      *             AFFECTED PARAGRAPHS:                        *
      *             - 13125-INIT                                *
      *             - 13150-INIT                                *
      *             - 13550-CALC-STANDARD                       *
      *             - 13550-DEVICE-COMPUTE                      *
      *           - CREATED W-2014-BLOOD-APC-TABLE, ORDERING    *
      *             BLOOD DEDUCTIBLE HCPCS FROM LOW TO HIGH     *
      *             APC RATE                                    *
      *           - UPDATED LIST OF BLOOD DEDUCTIBLE HCPCS IN   *
      *             PARAGRAPH 13655-SET-BD-HCPCS-FLAG TO        *
      *             REFLECT CY 2014 ORDER OF LOW TO HIGH APC    *
      *             PAYMENT RATE                                *
      *           - REFERENCED W-2014-BLOOD-APC-TABLE VARIABLES *
      *             IN PARAGRAPH 13150-INIT                     *
      *           - NO UPDATES TO PT DEVICE OFFSET LOGIC IN PAR *
      *             13665-SET-PTD-LINE-FLAG & PARAGRAPH         *
      *             13670-SET-PTD-PROC-FLAG                     *
      *           - NO UPDATES TO BASEPTDO & OPPSPTDO           *
      *           - UPDATED BASEAPCS & OPPSAPCS,                *
      *                     BASEWNXC & OPPSWNXC,                *
      *                     BASEPTCO & OPPSPTCO,                *
      *                     BASEPTRO & OPPSPTRO,                *
      *                     BASEPTRH & OPPSPTRH,                *
      *                     BASEPTCH & OPPSPTCH                 *
      *           - CREATED OPPSMH14,                           *
      *                     OPPSPH14,                           *
      *                     DEVCR14                             *
      *           - ADDED COPY STATEMENTS FOR TABLES):          *
      *             - OPPSMH14                                  *
      *             - OPPSPH14                                  *
      *             - DEVCR14                                   *
      *           - REFERENCED 2014 MH TABLE IN PARAGRAPH       *
      *             13150-INIT                                  *
      *           - REFERENCED 2014 PHP TABLE IN PARAGRAPH      *
      *             13150-INIT                                  *
      *           - REFERENCED 2014 DEVICE CREDIT TABLE IN      *
      *             PARAGRAPHS 13550-DEVICE-CREDIT &            *
      *             13550-DEVICE-COMPUTE                        *
      *           - RE-CREATED BASEAPCS AND OPPSAPCS USING      *
      *             CORRECTED APC TABLE FROM POLICY STAFF       *
      *                                                         *
      * 12/12/13- CREATE VERSION 2014.1.1 (JANUARY 2014)        *
      * 2014.1.1  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (234 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 01/27/14- CREATE VERSION 2014.2.0 (APRIL 2014)          *
      * 2014.2.0  - REVISED DEVICE CREDIT LOGIC TO REFLECT      *
      *             NEW METHODOLOGY                             *
      *                                                         *
      *             AFFECTED PARAGRAPHS:                        *
      *             - 13550-DEVICE-COMPUTE                      *
      *             - 13550-SCH-ADJ                             *
      *                                                         *
      *             NEW VARIABLE:                               *
      *             - H-LINE-DEVCR-PYMT-RATE                    *
      *               (REPLACES H-DEVCR-PYMT-RATE)              *
      *                                                         *
      *           - MOVED THE FOLLOWING VARIABLES FROM          *
      *             H-ADDITIONAL-VARIABLES TO LINE-HOLD-ITEMS   *
      *             TO ENSURE THEY ARE INITIALIZED LINE LEVEL   *
      *             - H-PHP-LITEM-PYMT-OUTL                     *
      *             - H-LINE-DEVCR-PYMT-RATE                    *
      *             - H-LINE-DEVCR-AMT                          *
      *                                                         *
      * 02/12/14- UPDATE VERSION 2014.2.0 (APRIL 2014)          *
      * 2014.2.0  - UPDATED VERSION NUMBER TO REFLECT QUARTER 2 *
      *           - UPDATED COPYBOOK OPPSPTCH TO INCLUDE NEW    *
      *             SKIN SUBSTITUTE THERASKIN (Q4121).          *
      *                                                         *
      *                                                         *
      * 03/12/14- CREATE VERSION 2014.2.1 (APRIL 2014)          *
      * 2014.2.1  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (231 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 03/25/14- CREATE VERSION 2014.2.2 (APRIL 2014) *FIX*    *
      * 2014.2.2  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (232 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 04/04/14- CREATE VERSION 2014.2.3 (APRIL 2014) *FIX*    *
      * 2014.2.3  - MOVED THE FOLLOWING VARIABLE FROM           *
      *             LINE-HOLD-ITEMS TO H-ADDITIONAL-VARIABLES   *
      *             TO ENSURE IT IS NOT SET TO ZERO BEFORE      *
      *             BEING USED IN THE OUTLIER CALCULATION.      *
      *             FIX IS IN RESPONSE TO HPAR HPAR CR8653H.    *
      *             - H-PHP-LITEM-PYMT-OUTL                     *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 03/12/14- CREATE VERSION 2014.3.0 (JULY  2014)          *
      * 2014.3.0  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (248 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 03/16/14- CREATE VERSION 2014.3.0 (JULY 2014)           *
      * 2014.3.0  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             (249 TOTAL APC RECORDS ADDED/UPDATED)       *
      *           - 3/12/14 APC TABLE CHANGES REVERTED TO       *
      *             2014.2.3. CORRECTED TABLE ISSUED 3/13/2014  *
      *             USED.                                       *
      *                                                         *
      * 09/10/14- CREATE VERSION 2014.4.0 (OCTOBER 2014 ASP)    *
      * 2014.4.0  - UPDATED APC TABLE WITH NEW ASP DRUG RATES   *
      *             WITH 248 RECORDS ADDED/UPDATED              *
      *           - UPDATED W-STORAGE-REF                       *
      *                                                         *
      * 10/15/14- CREATE VERSION 2015.1.0 (JANUARY 2015)        *
      * 2015.1.0  - UPDATED W-STORAGE-REF                       *
      *           - REMOVED CODE PRIOR TO 2007                  *
      *           - REVISED FLOOR LOGIC                         *
      * 11/05/14- CLEANED UP COMMENTS, UNUSED AND COMMENTED OUT *
      *           SECTIONS OF CODE - RJ                         *
      * 11/12/14- CORRECTED DEVICE CREDIT LOGIC IN PARAGRAPHS   *
      *           13550-SCH-ADJ AND 14550-SCH-ADJS (ADDED       *
      *           PARENTHESES TO IF CONDITION) - RJ             *
      * 11/13/14- CORRECTED WAGE INDEX RECORD DATE CRITERIA     *
      *           LOGIC AND WAGE INDEX ASSIGNMENT LOGIC - TH    *
      *           PARAGRAPHS:   14200-CALC-WAGEINDX AND         *
      *                         14210-WAGE-LOOKUP               *
      *           NEW VARIABLE: W-WCW-DTCD                      *
      * 11/14/14- SET H-IP-LIMIT TO 1260 FOR CY 2015 IN         *
      *           PARAGRAPH 14100-INIT - TH                     *
      *         - SET THE CY 2015 OUTLIER THRESHOLD DOLLAR AMT  *
      *           TO 2775 IN PARAGRAPH 14600-ADJ-CHRG-OUTL - TH *
      *         - UPDATED REFERENCES TO POINT TO THE CY 2015    *
      *           DEVICE CREDIT TABLE IN PARAGRAPHS:            *
      *           14125-INIT, 14150-INIT, 14550-DEVICE-CREDIT,  *
      *           AND 14550-DEVICE-COMPUTE - TH                 *
      *         - CORRECT ORDER OF BLOOD DEDCUTIBLE HCPCS       *
      *           IN W-2015-BLOOD-APC-FILLS (LOWEST TO HIGHEST  *
      *           APC RATE) - TH                                *
      *         - ADDED VALID CY 2015 PT DEVICE OFFSET HCPCS    *
      *           IN PARAGRAPH 14665-SET-PTD-LINE-FLAG - TH     *
      *         - ADDED VALID CY 2015 PT DEVICE - PROCEDURE     *
      *           PAIRINGS IN PARAGRAPH 14670-SET-PTD-PROC-FLAG *
      * 12/18/14- ADDED '11' PAYMENT ADJUSTMENT FLAG            *
      * 2015.1.1- UPDATED W-STORAGE-REF                         *
      *                                                         *
      * 12/22/14- SET PAYMENT FLAG '11' TO CHANGE SERVICE UNITS *
      *           TO 1. PARAGRAPH 14125-INIT.                   *
      *         - MOVE SERVICE UNIT OVERRIDE FOR APC 0339       *
      *           TO PARAGRAPH 14125-INIT.                      *
      *                                                         *
      * 01/08/15- ADDED A-DEVICE-CREDIT-QD TO OUTPUT            *
      * 2015.3.B- UPDATED W-STORAGE-REF                         *
      *                                                         *
      * 02/18/15- FIXED A-DEVICE-CREDIT-QD DECLARATION TYPO     *
      * 2015.3.C- UPDATED W-STORAGE-REF (SECOND BETA RELEASE)   *
      *                                                         *
      * 05/04/15- UPDATED PTDO OFFSET CALCULATION TO REFLECT    *
      * 2015.3.0  NO PAYMENT WHEN OFFSET IS GREATER THAN PAYMENT*
      *         - UPDATED W-STORAGE-REF                         *
      * 05/05/15- MAPPED / ACCUMULATED DEVICE CREDIT AMOUNT TO  *
      *           A-DEVICE-CREDIT-QD OUTPUT FIELD (2014 & 2015) *
      *         - REMOVED LOGIC TO SET UNITS TO 1 WHEN PAF '11' *
      * 05/13/15- ADDED PTD PAIRINGS FOR C2623 & C2613          *
      * 05/18/15- UPDATED W-PTD-CNT.                            *
      *                                                         *
      * 09/16/15- CREATE VERSION 2016.1.B (JANUARY 2016 BETA)   *
      * 2016.1.B  - UPDATED W-STORAGE-REF                       *
      * BETA      - ADDED NEW FIELDS TO LINKAGE SECTION         *
      *             FOR INTERFACE CHANGE TO RECEIVE NEW PAYER   *
      *             ONLY VALUE CODES QN - QW (10)               *
      *             L-PAYER-ONLY-VALUE-CODES                    *
      *                                                         *
      * 10/14/15- CREATE VERSION 2016.1.0 (JANUARY 2016 PROD)   *
      * 2016.1.0  - UPDATED W-STORAGE-REF                       *
      * PROD      - UPDATED CAL-VERSION14 TO REFLECT QTR 4      *
      *           - ADDED CAL-VERSION15 FOR 2016                *
      *           - CREATED NEW SECTION FOR 2016                *
      *           - ADDED NEW STATE CODES EFFECTIVE APRIL 2016  *
      *           - ADDED STATE CODE '55' FOR CA IN 2015 SECTION*
      *           - UPDATED ALL 2016 TABLES/COPYBOOKS           *
      *             - BASEAPCS, OPPSAPCS                        *
      *             - BASEWNXC, OPPSWNXC                        *
      *             - W-2016-BLOOD-APC-TABLE                    *
      *             - BASEPTCO, OPPSPTCO                        *
      *             - BASEPTCH, OPPSPTCH                        *
      *             - BASEPTRO, OPPSPTRO                        *
      *             - BASEPTRH, OPPSPTRH                        *
      *             - DEVCR16                                   *
      *           - UPDATED INPATIENT DAILY COINSURANCE AND     *
      *             OUTLIER THRESHOLD FOR 2016                  *
      *           - ADDED NEW VALID STATUS INDICATOR 'J2'       *
      *           - ADDED NEW VALID PAYMENT ADJUSTMENT FLAGS:   *
      *             - '12' - PT DEVICE OFFSET VALUE CODE QN     *
      *             - '13' - PT DEVICE OFFEST VALUE CODE QO     *
      *             - '14' - CT SCAN REDUCTION                  *
      *           - ADDED NEW LOGIC FOR CT SCAN 5% REDUCTION    *
      *             USING PAF 14                                *
      *           - REMOVED CY 2007 AND 2008 SECTIONS AND       *
      *             RELATED DATA ITEMS BECAUSE PROGRAM WAS TOO  *
      *             LONG FOR A SUCCESSFUL COMPILE               *
      *             (BLOOD HCPCS AND PAID AT COST TABLES NOT    *
      *             USED AFTER 2007/2008 AND WERE REMOVED.      *
      *             OPPSWINX MASA WAGE INDEX TABLE ALSO REMOVED *
      *             (NOT USED SINCE 2005).                      *
      *           - ALTER PASS-THROUGH DEVICE OFFSET LOGIC FOR  *
      *             2016.  STOP USING PTDO TABLES AND PAIRING   *
      *             LOGIC IN PRICER.  INSTEAD RECEIVE INPUT     *
      *             FROM THE IOCE TO DETERMINE WHICH LINES TO   *
      *             REDUCE BY THE PTDO AND HOW MUCH TO REDUCE   *
      *             USING VALUE CODES QN & QO, AND PAFS 12 & 13 *
      *             - NEW VARIABLES:                            *
      *               H-QN-TOT-PTD-CHARGES                      *
      *               H-QO-TOT-PTD-CHARGES                      *
      *               H-QN-WA-PTD-OFFSET                        *
      *               H-QO-WA-PTD-OFFSET                        *
      *               H-TOT-PTD-CHARGES                         *
      *               H-WA-PTD-OFFSET                           *
      *             - RELATED PARAGRAPHS:                       *
      *               15000-PROCESS-MAIN-NEW                    *
      *               15150-INIT                                *
      *               15555-CALC-H-STANDARD                     *
      *               15556-CALC-PTD-OFFSET                     *
      *           - REMOVE PASS-THROUGH DEVICE TO PROCEDURE     *
      *             PAIRING LOGIC FOR OUTLIER CALCULATION       *
      *           - REMOVE SRS CAP LOGIC (HCPCS 77371)          *
      *           - REMOVE APC 0339 UNITS OVERRIDE              *
      *           - INCREASED SIZE OF H-RATIO FROM S9(03)V9(07) *
      *             TO S9(07)V9(07) TO CORRECT COINSURANCE CALC *
      *                                                         *
      * 02/05/16- CREATE VERSION 2016.2.0 (APRIL 2016 PROD)     *
      * 2016.2.0  - UPDATED W-STORAGE-REF                       *
      * PROD      - UPDATED CAL-VERSION15 TO REFLECT QTR 2      *
      *           - ADDED NEW HCPCS CODE TO BASEPTRH & OPPSPTRH *
      *           - ADDED LOGIC TO APPLY TERMINATED PROCEDURE   *
      *             DEVICE OFFSET USING PAYER ONLY VALUE CODE   *
      *             QQ & PAYMENT ADJUSTMENT FLAG '16'           *
      *           - ADDED LOGIC TO APPLY DEVICE CREDIT USING    *
      *             PAYER ONLY VALUE CODE QQ & PAYMENT          *
      *             ADJUSTMENT FLAG '17'                        *
      *           - REMOVED DEVCR16 COPYBOOK AS IT'S NO LONGER  *
      *             USED                                        *
      *                                                         *
      * 04/12/16- CREATE VERSION 2016.3.0 (JULY 2016 PROD)      *
      * 2016.3.0  - UPDATED W-STORAGE-REF                       *
      * PROD      - UPDATED CAL-VERSION15 TO REFLECT QTR 3      *
      *           - ADD LOGIC TO USE L-PAYER-ONLY-VC-QP & PAF   *
      *             15 FROM THE IOCE TO PROCESS A THIRD         *
      *             PASS-THROUGH DEVICE OFFSET.                 *
      *             ADD '15' AS A VALID PAF VALUE.              *
      *             - NEW VARIABLES:                            *
      *               H-QP-TOT-PTD-CHARGES                      *
      *               H-QP-WA-PTD-OFFSET                        *
      *             - RELATED PARAGRAPHS:                       *
      *               15000-PROCESS-MAIN-NEW                    *
      *               15150-INIT                                *
      *               15555-CALC-H-STANDARD                     *
      *               15556-CALC-PTD-OFFSET                     *
      *           - DISABLE OLD PASS-THROUGH DRUG OFFSET LOGIC  *
      *             (PT CONTRAST & PT RADIOPHARM)               *
      *           - COMMENT OUT VALUE CODE QP LOGIC FOR FUTURE  *
      *             IMPLEMENTATION                              *
      *           - CHANGE LOGIC TO USE L-PAYER-ONLY-VC-QU      *
      *             INSTEAD OF L-PAYER-ONLY-VC-QQ FOR DEVICE    *
      *             CREDIT CAP AMOUNT.  QU PAIRS WITH PAF 17.   *
      *           - USE L-PSF-STATE-CODE INSTEAD OF             *
      *             L-PSF-PROV-ST FOR RURAL FLOOR WAGE INDEX    *
      *             LOGIC (15100-INIT) FOR CR 9567 - NEW        *
      *             STATE CODE VALUES                           *
      *           - RESTORE OLD PASS-THROUGH DRUG OFFSET LOGIC  *
      *             (PT CONTRAST & PT RADIOPHARM)               *
      *           - ADD SPECIAL LOGIC FOR LINES ELIGIBLE FOR    *
      *             BLOOD DEDUCTIBLE & BILLED WITH A            *
      *             COMPREHENSIVE APC (FOR 2015 AND 2016)       *
      *             - CREATE FLAG TO ID CLAIMS WITH A           *
      *               COMPREHENSIVE APC: C-APC-CLAIM-FLAG       *
      *             - ADD LOGIC TO FLAG CLAIMS WITH A C-APC     *
      *               14125-INIT, 15125-INIT                    *
      *             - ADD LOGIC TO IDENTIFY LINES ELIGIBLE FOR  *
      *               BLOOD DEDUCTIBLE ON A C-APC CLAIM & ADD   *
      *               THE CHARGES OF THESE LINES TO CLAIM'S     *
      *               TOTAL PACKAGED LINE CHARGES               *
      *               14150-INIT, 15150-INIT                    *
      *             - EXCLUDE LINE FROM DRUG COINSURANCE ROLL-UP*
      *               TABLE (SO AS NOT TO CONTRIBUTE TO DAILY   *
      *               COIN TOTAL FOR COMPARISON WITH INPATIENT  *
      *               DAILY COIN CAP)                           *
      *               14400-CALCULATE, 15400-CALCULATE          *
      *             - ADD LOGIC TO IDENTIFY LINES ELIGIBLE FOR  *
      *               BLOOD DEDUCTIBLE ON A C-APC CLAIM &       *
      *               ENSURE NON-BLOOD DEDUCTIBLE, COINSURANCE, *
      *               AND REIMBURSEMENT AREN'T CALCULATED ($0)  *
      *               14550-CALC-STANDARD, 15550-CALC-STANDARD  *
      *             - CALCULATE THE LINE PAYMENT, CALCULATE THE *
      *               BLOOD DEDUCTIBLE, AND SET THE LINE        *
      *               PAYMENT EQUAL TO THE BLOOD DEDUCTIBLE     *
      *               14550-CALC-GJK, 15550-CALC-GJK            *
      *             - EXCLUDE LINE PAYMENT FROM CLAIM'S TOTAL   *
      *               PAID LINE PAYMENTS (FOR OUTLIER CALC)     *
      *               14500-ADJ-CHRGS, 15500-ADJ-CHRGS          *
      *             - ADD LOGIC TO IDENTIFY LINES ELIGIBLE FOR  *
      *               BLOOD DEDUCTIBLE ON A C-APC CLAIM &       *
      *               EXCLUDE LINE FROM THE OUTLIER CALCULATION *
      *               14600-ADJ-CHRG-OUTL, 15600-ADJ-CHRG-OUTL  *
      *             - UPDATE RADIOPHARM HCPCS TABLES            *
      *               (BASEPTRH, OPPSPTRH)                      *
      *             - IDENTIFY THE REVENUE CODE IN OCE-IN-LINES *
      *               (OPPS-LITEM-RVCD) TO USE TO DETERMINE     *
      *               BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE     *
      *               LINES ON COMPREHENSIVE APC CLAIMS         *
      *             - MODIFIED LOGIC TO IDENTIFY REVENUE CODE   *
      *               39X LINES & INCLUDE THEM IN THE BLOOD     *
      *               DEDUCTIBLE RATIO CALCULATION FOR CLAIMS   *
      *               WITH BLOOD DEDUCTIBLE LINE(S) & A         *
      *               COMPREHENSIVE APC                         *
      *               14150-INIT, 15150-INIT                    *
      *                                                         *
      * 07/15/16- CREATE VERSION 2017.1.B (JANUARY 2017 BETA)   *
      * 2016.1.B  - UPDATED W-STORAGE-REF WITH NEW VERSION #    *
      * BETA      - ADDED CAL-VERSION16 FOR CY 2017 CALL        *
      *           - ADDED NEW 16000 SECTION FOR CY 2017 LOGIC   *
      *  LOGIC ADDED TO EXISITING PARAGRAPHS:                   *
      *     - 16150-INIT                                        *
      *     - 16555-CALC-H-STANDARD                             *
      *     - 16600-ADJ-CHRG-OUTL                               *
      *  NEW VARIABLES:                                         *
      *     - CT-REDUCT-2017                                    *
      *     - L-PSF-ESRD-CHILD-QUAL-IND                         *
      *     - L-PSF-DEVICE-CCR                                  *
      *     - L-PSF-CARRIER-LOCAL                               *
      *     - XRAY-REDUCT-2017                                  *
      *  -ADD SERVICE INDICATORS 'G' AND 'K' TO INVALID LIST    *
      *  -ADD PMF '6' DETERMINE PYMT NO OUTLIER PYMT APPLIED    *
      *  -ADD '21' TO OPPS-PYMT-ADJ-FLAG                        *
      *  -REMOVE DRUG PRICING LOGIC FOR ASP DRUGS               *
      *  -UPDATE CT REDUCTION LOGIC:                            *
      *      - CT-REDUCT-2016 = 5%                              *
      *      - CT-REDUCT-2017 = 15%                             *
      *                                                         *
      * 10/14/16- CREATE VERSION 2017.1.0 (JANUARY 2017 PROD)   *
      * 2017.1.0  - UPDATED W-STORAGE-REF                       *
      * PROD      - REMOVED LOGIC THAT APPLIES THE FILM X-RAY   *
      *             REDUCTION TO THE PRIMARY COMPOSITE LINE     *
      *             WHEN THE X-RAY LINE IS PACKAGED (CAF 'XF')  *
      *           - CHANGE VARIABLE XRAY-REDUCT-2017 TO         *
      *             XRAY-FILM-REDUCT-2017                       *
      *           - REMOVED CY 2009 SECTION AND                 *
      *             RELATED DATA ITEMS BECAUSE PROGRAM WAS TOO  *
      *             LONG FOR A SUCCESSFUL COMPILE               *
      *             (APC PASS-THROUGH DEVICE OFFSET TABLE NOT   *
      *             USED AFTER 2009 AND WAS REMOVED.)           *
      *           - ADDED '7' AND '8' TO THE LIST OF VALID      *
      *             PAYMENT METHOD FLAG (OPPS-SITE-SRVC-FLAG)   *
      *             VALUES FOR SECTION 603 SERVICES             *
      *             (MODIFIER PN)                               *
      *           - ADDED VARIABLE AND LOGIC TO REDUCE APC RATE *
      *             OF ELIGIBLE SECTION 603 SERVICES BY 50% =   *
      *             PHYSICIAN FEE SCHEDULE (PFS) RATE           *
      *             NEW VARIABLE: PFS-REDUCT-2017 = 0.500       *
      *             APPLIES WHEN OPPS-SITE-SRVC-FLAG = "8"      *
      *           - EXCLUDED 603 SERVICES FROM QUALITY          *
      *             REDUCTION LOGIC (PMT METHOD FLAG = 7 OR 8)  *
      *           - ADDED VARIABLE AND LOGIC TO CALCULATE       *
      *             COINSURANCE OF ELIGIBLE 603 SERVICES AS 20% *
      *             OF THE APC PAYMENT = PFS COINSURANCE RATE   *
      *             NEW VARIABLE: COIN-RATE-20 = 0.20           *
      *             APPLIES WHEN OPPS-SITE-SRVC-FLAG = "8"      *
      *             ALSO SET THE REIMBURSEMENT RATE (H-PPCT)    *
      *             NEW VARIABLE: PFS-REIM-RATE = 0.80          *
      *           - EXCLUDED SECTION 603 SERVICE LINES FROM     *
      *             THE SCH ADJUSTMENT                          *
      *           - ADDED LOGIC TO CALCULATE THE MIN, MAX, AND  *
      *             REDUCED COINSURANCE FOR SECTION 603 SERVICES*
      *           - ADDED LOGIC TO EXCLUDE SECTION 603 SERVICES *
      *             FROM THE OUTLIER PAYMENT CALCULATION        *
      *           - ADDED LOGIC TO EXCLUDE SECTION 603 SERVICES *
      *             FROM THE INPATIENT DEDUCTIBLE CAPPING       *
      *             LOGIC                                       *
      *           - REMOVED PHP AND MENTAL HEALTH HCPCS FROM    *
      *             THE PAYMENT METHOD FLAG AND DENIAL/         *
      *             REJECTION FLAG VALIDATION LOGIC             *
      *           - DISABLED ALL LOGIC USED TO APPLY THE APC    *
      *             CAP TO CMHC PHP LINES FOR THE OUTLIER       *
      *             CALCULATION                                 *
      *           - REMOVED LOGIC THAT CHECKS FOR PHP & MENTAL  *
      *             HEALTH HCPCS AND APCS                       *
      *           - CHANGED THE OUTLIER THRESHOLD FROM 3250     *
      *             TO 3825                                     *
      *           - CHANGED THE INPATIENT DEDUCTIBLE CAP        *
      *             (H-IP-LIMIT) FROM 1288 TO 1316              *
      *           - CREATED W-2017-BLOOD-APC-TABLE TO HOLD THE  *
      *             2017 LIST OF BLOOD DEDUCTIBLE HCPCS,        *
      *             UPDATED TABLE REFERENCES IN 16150-INIT, AND *
      *             UPDATED THE LIST IN 16655-SET-BD-HCPCS-FLAG *
      *           - UPDATED BASEAPCS & OPPSAPCS (713 NEW RECS)  *
      *           - UPDATED BASEWINC & OPPSWINC IN V 2017.1.B   *
      *           - DELETED DISABLED LOGIC                      *
      *           - UPDATED BASEAPCS & OPPSAPCS WITH CORRECTED  *
      *             RATES AND INCREASED THE RATE FIELDS TO      *
      *             EIGHT DIGITS - 9(6)V99; 714 RECORDS         *
      *           - CHANGED 16550-CALC-GJK TO 16550-CALC-RU     *
      *                                                         *
      * 01/09/17- CREATE VERSION 2017.3.0 (JULY 2017 PROD)      *
      * 2017.3.0  - UPDATED W-STORAGE-REF & CAL-VERSION16       *
      *           - ADD '3' TO LINE ITEM D/R FLAG FISS          *
      *             INFORMATIONAL USE                           *
      *           - ADD PMF FLAG '9' VALUE TO VALID LIST TO     *
      *             BYPASS OUTLIER CAP LOGIC                    *
      *           - FOR CYS 2016 AND 2017, CHANGED THE LOCATION *
      *             OF THE DEVICE CREDIT SELECTION LOGIC TO     *
      *             ENSURE THAT PROVIDERS WITH A SPECIAL PAYMENT*
      *             INDICATOR OF '1' OR '2' IN THE OPSF RECEIVE *
      *             THE DEVICE CREDIT.                          *
      *           - FOR CY 2017, ADDED LOGIC TO CAP TOTAL CMHC  *
      *             OUTLIER PAYMENTS AT 8% OF TOTAL PAYMENTS.   *
      *           - NEW LOGIC ADDED TO PARAGRAPHS:              *
      *                 15100-INIT.                             *
      *                 16100-INIT.                             *
      *                 16150-INIT.                             *
      *                 16600-ADJ-CHRG-OUTL.                    *
      *                 16610-CMHC-OUTL-CAP.                    *
      *           - NEW PARAGRAPHS:                             *
      *                 16610-CMHC-OUTL-CAP.                    *
      *                 16610-CMHC-OUTL-CAP-EXIT.               *
      *           - NEW VARIABLES:                              *
      *              - L-PSF-COUNTY-CODE                        *
      *              - L-PSF-PYMT-CBSA                          *
      *              - FILLER                                   *
      *              - L-PRIOR-OUTL-TOTAL (INPUT)               *
      *              - L-PRIOR-PYMT-TOTAL (INPUT)               *
      *              - H-CMHC-PYMT-TOTAL  (TOTAL CMHC PMTS)     *
      *              - H-CMHC-OUTL-TOTAL  (TOTAL CMHC OUTL PMTS)*
      *              - H-CMHC-OUTL-PCT    (QUOTIENT OF OUTL/PMTS*
      *              - CMHC-OUTL-CAP-PCT  (.08)                 *
      * 04/04/17- CREATE VERSION 2017.3.1 (JULY 2017 PROD)      *
      * 2017.3.1  - UPDATED W-STORAGE-REF                       *
      *           - UPDATE LOGIC TO PREVENT NEGATIVE OUTLIER    *
      *             PAYMENT                                     *
      * 05/08/17- CREATE VERSION 2018.1.B (JANUARY 2018 BETA)   *
      * 2018.1.B  - UPDATED W-STORAGE-REF                       *
      *           - CREATE NEW CAL-VERSION17                    *
      *           - CREATE NEW SECTION:                         *
      *               17000-PROCESS-MAIN-NEW                    *
      *               17900-END-PRICE-RTN-EXIT                  *
      *          -ADDED L-PSF-SPEC-PYMT-IND = 'D'               *
      *              USE THE WAGE INDEX CBSA FOR THE WAGE INDEX *
      *              AND SELECT THE AREA WAGE INDEX (1ST COLUMN)*
      *          -ADDED LOGIC TO APPLY THE RURAL SCH ADJ TO THE *
      *             FINAL PAYMENT IF L-PSF-PYMT-CBSA (PYMT CBSA)*
      *           - NEW LOGIC ADDED TO PARAGRAPHS:              *
      *               17100-INIT.                               *
      *               17100-INIT-EXIT.                          *
      *               17550-SCH-ADJ.                            *
      *               17550-SCH-ADJ-EXIT.                       *
      *           - NEW PARAGRAPHS:                             *
      *               17120-GET-OUTM-ADJ                        *
      *               17120-GET-OUTM-ADJ-EXIT                   *
      *           - NEW VARIABLES:                              *
      *               PYMT-CBSA-FLAG                            *
      *               RURAL-PYMT                                *
      *               OUTM-CNTY                                 *
      *               OUTM-ADJ-FACT                             *
      *               OUTM-IND                                  *
      *               OUTM-IDX                                  *
      *               OUTM-IDX2                                 *
      *               HLD-OUTM-ADJ                              *
      *           - NEW TABLE:  COUNTY CODE & OUTMIGRATION ADJ. *
      *               OPPSOUTM  (NEW FOR CY 2018)               *
      * 07/18/17- CREATE VERSION 2018.1.0 (JANUARY 2018 PROD)   *
      *        - CHANGED THE OUTLIER THRESHOLD FROM 3825        *
      *          TO 4150                                        *
      *        - CHANGED THE INPATIENT DEDUCTIBLE CAP           *
      *          (H-IP-LIMIT) FROM 1316 TO 1340                 *
      *        - ADD '22' TO OPPS-PYMT-ADJ-FLAG                 *
      *        - ADDED VARIABLE AND LOGIC TO REDUCE APC RATE    *
      *             OF ELIGIBLE SECTION 603 SERVICES BY 40% =   *
      *             PHYSICIAN FEE SCHEDULE (PFS) RATE           *
      *             APPLIES WHEN OPPS-SITE-SRVC-FLAG = "8"      *
      *        - UPDATE LOGIC FOR APPLICATION OF COINSURANCE    *
      *             ON THE CAP TO USE THE ACTUAL COINSURANCE    *
      *             INSTEAD OF THE NATIONAL COINSURANCE         *
      *        - CREATED W-2018-BLOOD-APC-TABLE TO HOLD THE     *
      *             2018 LIST OF BLOOD DEDUCTIBLE HCPCS,        *
      *             UPDATED TABLE REFERENCES IN 17150-INIT, AND *
      *             UPDATED THE LIST IN 17655-SET-BD-HCPCS-FLAG *
      *        - REVISED 2017 LOGIC FOR BLOOD DEDUCTIBLE TABLE  *
      *             IN SECTION 16150-INIT                       *
      *  LOGIC ADDED TO EXISITING PARAGRAPHS:                   *
      *           - 16150-INIT                                  *
      *           - 17150-INIT                                  *
      *           - 17480-RANK-COIN                             *
      *           - 17655-SET-BD-HCPCS-FLAG                     *
      *           - 17810-PROCESS-TYPE1                         *
      *  NEW VARIABLES:                                         *
      *      - PFS-REDUCT-2018 = 0.400                          *
      *      - XRAY-CRT-REDUCT-2018 - 7% REDUCTION FOR CRT XRAY *
      *           REDUCTION RATE WILL CHANGE TO 10% FOR CY 2023 *
      *  UPDATED TABLES & COPYBOOKS:                            *
      *           -   OPPSOUTM                                  *
      *           -   BASEWNXC & OPPSWNXC                       *
      *           -   BASEAPCS & OPPSAPCS                       *
      *           -   REMOVED CY 2010 COPYBOOKS                 *
      * 11/27/17- CREATE VERSION 2018.1.1 (JANUARY 2018 PROD)   *
      * 2018.1.1  - UPDATED W-STORAGE-REF                       *
      *  UPDATED TABLES:                                        *
      *           -   BASEAPCS & OPPSAPCS                       *
      * 07/31/18- CREATE VERSION 2018.4.0 (JANUARY 2018 PROD)   *
      * 2018.4.0  - UPDATED W-STORAGE-REF                       *
      *  UPDATED TABLES:                                        *
      *           -   BASEAPCS & OPPSAPCS                       *
      * 09/07/18- CREATE VERSION 2019.1.B (JANUARY 2019 BETA)   *
      * 2019.1.B  - UPDATED W-STORAGE-REF                       *
      *           - UPDATED LAYUP TABLE AREA FOR OPSF           *
      *           - CREATE NEW CAL-VERSION18                    *
      *           - CREATE NEW SECTION:                         *
      *               18000-PROCESS-MAIN-NEW                    *
      *               18900-END-PRICE-RTN-EXIT                  *
      *           - NEW VARIABLES:                              *
      *               L-PSF-PYMT-MODEL-ADJ                      *
      * 10/22/18- CREATE VERSION 2019.1.0 (JANUARY 2019 PROD)   *
      * 2019.1.0  - UPDATED W-STORAGE-REF                       *
      *           - CHANGED THE OUTLIER THRESHOLD FROM 4150     *
      *             TO 4825                                     *
      *           - CHANGED THE INPATIENT DEDUCTIBLE CAP        *
      *             (H-IP-LIMIT) FROM 1340 TO 1364              *
      *           - ADDED PAF (PAYMENT ADJUSMENT FLAG) '23' &   *
      *             '24'                                        *
      *           - ADDED PMF (PAYMENT METHOD FLAG) 'A'         *
      *               PAYS 70% OF THE APC RATE - 30% REDUCTION  *
      *           - NEW VARIABLES:                              *
      *               PMF-A-REDUCT-2019                         *
      *  LOGIC ADDED TO EXISITING PARAGRAPHS:                   *
      *           - 18100-INIT                                  *
      *           - 18550-CALC-STANDARD                         *
      *           - 18560-CALC-BENE-DEDUCT                      *
      *           - 18600-ADJ-CHRG-OUTL                         *
      *  UPDATED TABLES & COPYBOOKS:                            *
      *           -   OPPSOUTM                                  *
      *           -   BASEWNXC & OPPSWNXC                       *
      *           -   BASEAPCS & OPPSAPCS                       *
      *           -   NO CHANGES FOR BLOOD DEDUCTIBLE HCPC LIST *
      * 01/08/19- CREATE VERSION 2019.1.1 (JANUARY 2019 PROD)   *
      * 2019.1.1                                                *
      * NOTE: THE CHANGES BELOW ARE FOR CY'S 2017 AND 2018.     *
      *       LOGIC WILL MIMIC THE CY 2019 LOGIC THAT WAS       *
      *       PREVIOUSLY TESTED.                                *
      *                                                         *
      *           - PAF(PAYMENT ADJUSMENT FLAG) '23' RETRO      *
      *             ACTIVE TO 01/01/2017  ADDED TO SECTION      *
      *             16000 & 17000                               *
      *           - PAF(PAYMENT ADJUSMENT FLAG) '24' RETRO      *
      *             ACTIVE TO 01/01/2018 ADDED TO SECTION 17000 *
      *           - (OPPSOUTM) ADD THE CY 2018 ADJUSTMENT       *
      *             FACTORS FOR THE 2018 WAGE INDEX OUTMIGRATION*
      *             ADJUSTMENT.                                 *
      *                                                         *
      * 10/22/19- CREATE VERSION 2019.4.0 RE-RELEASE            *
      * NOTE: REMOVED OPPS-SITE-SRVC-FLAG = 'A' LOGIC DUE TO    *
      *       AMERICAN HOSPITAL ASSOCIATION ET AL V. AZAR       *
      *       LAWSUIT  EFF. 10/22/2019                          *
      *                                                         *
      * 11/08/19- CREATE VERSION 2020.1.0 (JANUARY 2019 PROD)   *
      *     REMOVED CY 2011 & 2012, PRICER ONLY STORES 7 YEARS  *
      *     PRICER NOW CALCULATES FOR CY 2013 - 2020            *
      * 2020.1.0  - UPDATED W-STORAGE-REF                       *
      *           - CREATE NEW CAL-VERSION19                    *
      *           - CHANGE QUALITY REDUCTION FROM 0.980 TO 0.981*
      *           - CHANGED THE OUTLIER THRESHOLD FROM 4825     *
      *             TO 5075                                     *
      *           - CHANGED THE INPATIENT DEDUCTIBLE CAP        *
      *             (H-IP-LIMIT) FROM 1364 TO 1408              *
      *           - ADD PMF ='X' TO VALID LIST OF PYMT METHOD   *
      *             FLAG, TREATED AS PMF ='7' UPDATED LOGIC     *
      *           - ADD PMF ='Y' TO VALID LIST OF PYMT METHOD   *
      *             FLAG, TREATED AS PMF ='8' UPDATED LOGIC     *
      *           - ADD PMF ='Z' TO VALID LIST OF PYMT METHOD   *
      *             FLAG, TREATED AS PMF ='0' UPDATED LOGIC     *
      *           - QUALITY ADJUSTMENT EXCLUSION FOR NEW        *
      *             TECHNOLOGY CATEGORY APC RANGES:             *
      *                - 1575-1599 (EFF. 1/1/2016)              *
      *                - 1901-1906 (EFF. 1/1/2017)              *
      *                - 1907-1908 (EFF. 1/1/2018)              *
      *           - UPDATED LOGIC TO PERFORM LOOKUP OF          *
      *             PROVIDERS RURAL FLOOR IN THIRD COLUMN OF    *
      *             WAGE INDEX TABLE                            *
      *     CREATE NEW SECTION:                                 *
      *             - 19000-PROCESS-MAIN-NEW                    *
      *             - 19900-END-PRICE-RTN-EXIT                  *
      *     CREATE NEW PARAGRAPHS:                              *
      *             - 19121-WI-QUARTILE-ADJ                     *
      *             - 19121-WI-QUARTILE-ADJ-EXIT                *
      *             - 19122-WI-TRANSITION-ADJ                   *
      *             - 19122-WI-TRANSITION-ADJ-EXIT              *
      *             - 19123-GET-PRIOR-CY-WI                     *
      *             - 19123-GET-PRIOR-CY-WI-EXIT                *
      *     NEW VARIABLES:                                      *
      *             - PMF-A-REDUCT-2020                         *
      *             - WI-QUARTILE-CY2020                        *
      *             - WI-PCT-REDUCT-CY2020                      *
      *             - WI-PCT-ADJ-CY2020                         *
      *             - H-PREV-WINX                               *
      *     UPDATED VARIABLES:                                  *
      *             - OUTM-IDX        PIC 9(04)                 *
      *     NEW COPYBOOKS:                                      *
      *             - OPPSWI19                                  *
      *     UPDATED TABLES & COPYBOOKS:                         *
      *             - BASEWNXC -ADDED THIRD COLUMN RURAL WI     *
      *             - OPPSWNXC -ADDED THIRD COLUMN RURAL WI     *
      *             - OPPSOUTM                                  *
      *      RETRO  - CREATED W-2019-BLOOD-APC-TABLE TO HOLD    *
      *               THE 2019 LIST OF BLOOD DEDUCTIBLE HCPCS   *
      *             - CREATED W-2020-BLOOD-APC-TABLE TO HOLD    *
      *               THE 2020 LIST OF BLOOD DEDUCTIBLE HCPCS   *
      *     REMOVED COPYBOOKS:                                  *
      *             - PHP-INDX10                                *
      *             - MH-INDX10                                 *
      *             - MH-INDX12                                 *
      *             - DEV-INDX11                                *
      *             - DEV-INDX12                                *
      *             - W11BD-INDX                                *
      *             - W12BD-INDX                                *
      *                                                         *
      * 06/25/20- CREATE VERSION 2020.3.0 (JULY 2020 PROD       *
      * 2020.3.0  - UPDATED W-STORAGE-REF                       *
      *           - UPDATED BASEAPCS AND OPPSAPCS               *
      *           - UPDATED CALVERSION                          *
      *           - IOCE VERSION - JULY 21.2 BETA               *
      *                                                         *
      * 08/27/20- CREATE VERSION 2021.1.B (JANUARY 2021 BETA)   *
      *     REMOVED 12000 SECTION , PRICER ONLY STORES 7 YEARS  *
      *     PRICER NOW CALCULATES FOR CY 2014 - 2021            *
      * 2021.1.B  - UPDATED W-STORAGE-REF                       *
      *           - CREATE NEW CAL-VERSION20                    *
      *           - UPDATE LINKAGE SECTION WITH NEW VARIABLES:  *
      *              - L-PSF-SUPPL-WI-IND                       *
      *              - L-PSF-SUPPL-WI                           *
      *     CREATE NEW SECTION:                                 *
      *             - 20000-PROCESS-MAIN-NEW                    *
      *             - 20900-END-PRICE-RTN-EXIT                  *
      *     UPDATE COPYBOOKS:                                   *
      *    TABLES REPLICATED  W/ 2020 DATA FOR CY2021 TESTING   *
      *    TABLES WILL BE UPDATED W/ 2021 DATA IN PROD RELEASE  *
      *             - BASEWNXC                                  *
      *             - OPPSWNXC                                  *
      * 09/22/20- CREATE VERSION 2021.1.0 (JANUARY 2021 PROD)   *
      * 2021.1.0  - UPDATED W-STORAGE-REF                       *
      *           - ADD PMF= 'B' FOR RO MODEL ADJUSTMENTS       *
      *           - APPLY 20% INSURANCE CAP AND INPATIENT       *
      *             DEDUCTIBLE CAP ON RO MODEL CLAIMS           *
      *           - ADD RO MODEL LOGIC (WILL NOT IMPLEMENT)     *
      *           - UPDATED BASEAPCS AND OPPSAPCS               *
      *           - UPDATED BASEWNXC AND OPPSWNXC               *
      *           - UPDATED OUTLIER THRESHOLD AMOUNT $5300      *
      *           - UPDATED QUALITY ADJUSTMENT FACTOR 0.9805    *
      *           - UPDATED INPATIENT DEDUCTIBLE FROM 1408 TO   *
      *             1484                                        *
      *           - CREATED W-2021-BLOOD-APC-TABLE TO HOLD      *
      *             THE 2021 LIST OF BLOOD DEDUCTIBLE HCPCS     *
      *       - NEW VARIABLES:                                  *
      *           - WI-QUARTILE-CY2021 = 0.8469                 *
      * 02/08/21- CREATE VERSION 2021.1.1                       *
      * 2021.1.1  - UPDATED W-STORAGE-REF                       *
      *           - UPDATED OPPSOUTM TABLE TO INCLUDE           *
      *             HISTORICAL DATA FOR CY 2018 - 2020          *
      * 02/23/21- CREATE VERSION 2021.1.2                       *
      * 2021.1.2  - UPDATED W-STORAGE-REF                       *
      *           - UPDATED LINKAGE SECTION WITH NEW FIELD:     *
      *               -  L-PSF-MPA                              *
      * 03/09/21- CREATE VERSION 2021.2.0                       *
      * 2021.2.0  - UPDATED W-STORAGE-REF                       *
      *           - UPDATED BASEAPCS AND OPPSAPCS               *
      *           - UPDATED CAL-VERSION                         *
      * 03/25/21- CREATE VERSION 2021.3.0                       *
      * 2021.3.0  - UPDATED W-STORAGE-REF                       *
      *           - UPDATED CAL-VERSION                         *
      *           - UPDATED LINKAGE SECTION WITH NEW FIELD:     *
      *               -   OPPS-PYMT-ADJ-FLAG2                   *
      * 05/12/21- CREATE VERSION 2021.3.1                       *
      * 2021.3.1  - UPDATED W-STORAGE-REF                       *
      * 07/21/21- CREATE VERSION 2021.4.0                       *
      * 2021.4.0  - UPDATED W-STORAGE-REF                       *
      *           - UPDATED CAL-VERSION                         *
      *           - UPDATED BASEAPCS AND OPPSAPCS               *
      *             -'02034','09538','09539'                    *
      *           - REVERT TO PAY 70% OF APC WITH PMF = 'A'     *
      *             FOR CY 2019 ('PO' MODIFIER) HCPCS = 'G0463' *
      ***********************************************************
      ***********************************************************
       DATE-COMPILED.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SOURCE-COMPUTER.            IBM-370.
       OBJECT-COMPUTER.            IBM-370.
       INPUT-OUTPUT  SECTION.
       FILE-CONTROL.

       DATA DIVISION.
       FILE SECTION.

       WORKING-STORAGE SECTION.

      ***************************************************************
      *   OPPS PRICER VERSION NUMBER (YYYY.Q.V - YEAR.QTR.VERSION)  *
      *-------------------------------------------------------------*
      *   UPDATE FOR EVERY NEW RELEASE                              *
      ***************************************************************
       01  W-STORAGE-REF                  PIC X(46)  VALUE
           'OPCAL2021.4.0 - W O R K I N G   S T O R A G E'.


      ***************************************************************   00000100
      *   OPPS PRICER CALCULATION SECTION VERSION                   *
      *-------------------------------------------------------------*
      *   UPDATE EVERY JANUARY & FOR ANY NEW SECTIONS CREATED       *   00000300
      *   MID-YEAR DUE TO A MAJOR LOGIC CHANGE                      *
      ***************************************************************   00000600
       01  CAL-VERSION13                  PIC X(07)  VALUE 'C2014.4'.
       01  CAL-VERSION14                  PIC X(07)  VALUE 'C2015.4'.
       01  CAL-VERSION15                  PIC X(07)  VALUE 'C2016.3'.
       01  CAL-VERSION16                  PIC X(07)  VALUE 'C2017.3'.
       01  CAL-VERSION17                  PIC X(07)  VALUE 'C2018.4'.
       01  CAL-VERSION18                  PIC X(07)  VALUE 'C2019.4'.
       01  CAL-VERSION19                  PIC X(07)  VALUE 'C2020.3'.
       01  CAL-VERSION20                  PIC X(07)  VALUE 'C2021.4'.
       01  R1                             PIC S9(04) COMP SYNC.
       01  R2                             PIC S9(04) COMP SYNC.
       01  R3                             PIC S9(04) COMP SYNC.
       01  R4                             PIC S9(04) COMP SYNC.



      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **                       COPYBOOKS                           **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
      *                                                             *
      *   1) APC RATE HISTORY TABLE                                 *
      *   2) CBSA WAGE INDEX HISTORY TABLE                          *
      *   3) PARTIAL HOSPITALIZATION HCPCS TABLES                   *
      *   4) MENTAL HEALTH HCPCS TABLES                             *
      *   5) DEVICE REDUCTION TABLES                                *
      *   6) STATE-SPECIFIC RURAL FLOOR BUDGET NEUTRALITY TABLES    *
      *   7) PASS-THROUGH RADIOPHARMACEUTICAL HCPCS HISTORY TABLE   *
      *   8) NUCLEAR MEDICINE PROCEDURE APC OFFSET HISTORY TABLE    *
      *   9) PASS-THROUGH CONTRAST AGENT HCPCS HISTORY TABLE        *
      *  10) CONTRAST AGENT PROCEDURE APC OFFSET HISTORY TABLE      *
      *  11) PASS-THROUGH DEVICE OFFSET HISTORY TABLE (NEW CY 2010) *
      *  12) DEVICE CREDIT CAP TABLES (NEW FOR CY 2014)             *
      *  13) OUTMIGRATION COUNTY CODE & ADJ TABLE(NEW FOR CY 2018)  *
      *                                                             *
      ***************************************************************


      ***************************************************************
      *   LAYUP TABLE AREA FOR APC HISTORY TABLE                    *
      *-------------------------------------------------------------*
      *   HISTORY TABLE IS UPDATED FOR EVERY JANUARY, TABLE NAME    *   00000300
      *   REMAINS THE SAME.                                         *
      ***************************************************************
      ****** WAA-INDX   ******************************
       COPY OPPSAPCS.


      ***************************************************************
      *   CBSA BASED WAGE INDEX HISTORY TABLE                       *
      *-------------------------------------------------------------*
      *   HISTORY TABLE IS UPDATED FOR EVERY JANUARY, TABLE NAME    *   00000300
      *   REMAINS THE SAME.                                         *
      ***************************************************************   00000600
      ****** WCM-INDX   ******************************
       COPY OPPSWNXC.


      ***************************************************************
      *   LAYUP TABLE AREA FOR ANNUAL PARTIAL HOSPITALIZATION       *
      *   (PHP) HCPCS LIST                                          *
      *-------------------------------------------------------------*   00000100
      *   THE PHP HCPCS TABLE IS NEW FOR CY 2008 (ADDED 11/5/2007). *   00000300
      *   ASK CCPG/DCCM IF THERE IS A NEW LIST EVERY JANUARY.       *   00000500
      *   WHEN THERE IS A NEW LIST, CREATE A NEW TABLE AND ADD IT   *   00000500
      *   TO THE LIST OF COPYBOOKS.                                 *   00000500
      *                                                             *   00000500
      *   CY 2013 - PHP-INDX13                                      *   00000500
      *   CY 2014 - PHP-INDX14                                      *   00000500
      *   CY 2015 - PHP-INDX14 - NO CHANGES, USE 2014 TABLE         *
      *   CY 2016 - PHP-INDX14 - NO CHANGES, USE 2014 TABLE         *
      *   CY 2017 - THIS TABLE IS NO LONGER USED; NO NEW VERSIONS   *
      *                                                             *   00000500
      ***************************************************************   00000600

      ****** PHP-INDX13 ******************************
       COPY OPPSPH13.

      ****** PHP-INDX14 ******************************
       COPY OPPSPH14.


      ***************************************************************
      *   LAYUP TABLE AREA FOR ANNUAL MENTAL HEALTH (MH) HCPCS LIST *
      *-------------------------------------------------------------*   00000100
      *   THE MH HCPCS TABLE IS NEW FOR CY 2008 (ADDED 11/5/2007).  *   00000300
      *   ASK CCPG/DCCM IF THERE IS A NEW LIST EVERY JANUARY.       *   00000500
      *   WHEN THERE IS A NEW LIST, CREATE A NEW TABLE AND ADD IT   *   00000500
      *   TO THE LIST OF COPYBOOKS.                                 *   00000500
      *                                                             *   00000500
      *   CY 2013 - MH-INDX13                                       *   00000500
      *   CY 2014 - MH-INDX14                                       *   00000500
      *   CY 2015 - MH-INDX14 - NO CHANGES, USE 2014 TABLE          *   00000500
      *   CY 2016 - MH-INDX14 - NO CHANGES, USE 2014 TABLE          *   00000500
      *   CY 2017 - THIS TABLE IS NO LONGER USED; NO NEW VERSIONS   *   00000500
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** MH-INDX13 *******************************
       COPY OPPSMH13.

      ****** MH-INDX14 *******************************
       COPY OPPSMH14.


      ***************************************************************
      *          THIS IS THE DEVICE REDUCTION TABLE (FB/FC)         *
      *          ASSOCIATED WITH DEVICES THAT ARE REPLACED          *
      *          FREE OF CHARGE WITH THEIR OFFSET AMOUNTS           *
      *-------------------------------------------------------------*
      *   THE DEVICE REDUCTION TABLE WAS NEW FOR CY 2007.           *
      *   CHECK WITH POLICY TO DETERMINE WHETHER A NEW TABLE IS     *   00000300
      *   NEEDED EACH JANUARY.                                      *
      *                                                             *   00000500
      *   CY 2013 - DEV-INDX13                                      *   00000500
      *   CY 2014 - REPLACED BY DEVICE CREDIT CAP TABLE CY 2014     *   00000500
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** DEV-INDX13 ******************************
       COPY DEVRED13.

      ***************************************************************
      *    LAYUP TABLE AREA FOR PASS-THROUGH RADIOPHARMACEUTICAL    *
      *                    HCPCS HISTORY TABLE                      *
      *-------------------------------------------------------------*
      *   THE PT RADIOPHARM TABLE WAS NEW FOR APRIL 2009            *
      *   CHECK WITH POLICY TO DETERMINE WHETHER TABLE UPDATES ARE  *   00000300
      *   NEEDED EACH QUARTER.  BECAUSE THIS IS A HISTORY TABLE,    *
      *   THE TABLE NAME REMAINS THE SAME.                          *
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** PTRH-INDX   *****************************
       COPY OPPSPTRH.


      ***************************************************************
      *    LAYUP TABLE AREA FOR PASS-THROUGH RADIOPHARMACEUTICAL    *
      *                   OFFSET HISTORY TABLE                      *
      *-------------------------------------------------------------*
      *   THE PT RADIOPHARM OFFSET TBL WAS NEW FOR APRIL 2009       *
      *   THIS TABLE LISTS NUCLEAR MEDICINE APCS WITH THEIR PER     *
      *   UNIT OFFSET AMOUNTS AND EFFECTIVE YEAR.  THESE OFFSETS    *
      *   ARE ASSOCIATED WITH PASS-THROUGH RADIOPHARM SERVICES.     *
      *   CHECK WITH POLICY FOR ANNUAL UPDATES / TABLES.            *   00000300
      *   BECAUSE THIS IS A HISTORY TABLE, THE TABLE NAME REMAINS   *
      *   THE SAME.                                                 *
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** PTRO-INDX   *****************************
       COPY OPPSPTRO.


      ***************************************************************
      *      LAYUP TABLE AREA FOR PASS-THROUGH CONTRAST AGENT       *
      *                    HCPCS HISTORY TABLE                      *
      *-------------------------------------------------------------*
      *   THE PT CONTRAST AGENT TABLE WAS NEW FOR JANUARY 2010      *
      *   CHECK WITH POLICY TO DETERMINE WHETHER TABLE UPDATES ARE  *   00000300
      *   NEEDED EACH QUARTER.  BECAUSE THIS IS A HISTORY TABLE,    *
      *   THE TABLE NAME REMAINS THE SAME.                          *
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** PTCH-INDX   *****************************
       COPY OPPSPTCH.


      ***************************************************************
      *  LAYUP TABLE AREA FOR PASS-THROUGH CONTRAST AGENT PROCEDURE *
      *                  APC OFFSET HISTORY TABLE                   *
      *-------------------------------------------------------------*
      *   THE PT CONTRAST AGENT OFFSET TBL WAS NEW FOR JANUARY 2010 *
      *   THIS TABLE LISTS CONTRAST AGENT PROC APCS WITH THEIR PER  *
      *   UNIT OFFSET AMOUNTS AND EFFECTIVE YEAR.  THESE OFFSETS    *
      *   ARE ASSOCIATED WITH PASS-THROUGH CONTRAST AGENT SERVICES. *
      *   CHECK WITH POLICY FOR ANNUAL UPDATES / TABLES.            *   00000300
      *   BECAUSE THIS IS A HISTORY TABLE, THE TABLE NAME REMAINS   *
      *   THE SAME.                                                 *
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** PTCO-INDX   *****************************
       COPY OPPSPTCO.


      ***************************************************************
      *  LAYUP TABLE AREA FOR PASS-THROUGH DEVICE OFFSET HISTORY    *
      *                            TABLE                            *
      *-------------------------------------------------------------*
      *   THE PT DEVICE OFFSET HISTORY TABLE WAS NEW FOR OCT 2010   *
      *   THIS TABLE LISTS DEVICE OFFSET HCPCS, OFFSET PROCEDURE    *
      *   UNIT OFFSET AMOUNTS AND EFFECTIVE YEAR.  THESE OFFSETS    *
      *   APCS, PER UNIT OFFSET AMOUNTS, EFFECTIVE DATES, AND       *
      *   TERMINATION DATES.                                        *
      *   CHECK WITH POLICY FOR ANNUAL UPDATES / TABLES.            *   00000300
      *   BECAUSE THIS IS A HISTORY TABLE, THE TABLE NAME REMAINS   *
      *   THE SAME.                                                 *
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** PTDO-INDX   *****************************
       COPY OPPSPTDO.


      ***************************************************************
      *          THIS IS THE DEVICE CREDIT CAP TABLE                *
      *          CONTAINS DEVICE DEPENDENT APCS WITH THEIR          *
      *          DEVICE CREDIT CAP AMOUNTS                          *
      *-------------------------------------------------------------*
      *   THE DEVICE CREDIT TABLE WAS NEW FOR CY 2014.              *
      *   CHECK WITH POLICY TO DETERMINE WHETHER A NEW TABLE IS     *   00000300
      *   NEEDED EACH JANUARY.  (REPLACES DEVICE REDUCTION TABLE)   *
      *                                                             *   00000500
      *   CY 2014 - DEV-INDX14                                      *   00000500
      *   CY 2015 - DEV-INDX15                                      *   00000500
      *   CY 2016 - NO LONGER USED AS OF APRIL 2016; DEVCR16 REMOVED*   00000500
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** DEV-INDX14 ******************************
       COPY DEVCR14.

      ****** DEV-INDX15 ******************************
       COPY DEVCR15.



      ***************************************************************
      *   OUTMIGRATION ADJUSTMENT AND COUNTY CODE LOOKUP TABLE      *
      *-------------------------------------------------------------*
      *   TABLE IS NEW FOR CY 2018                                  *   00000300
      ***************************************************************
      ****** OUTM-IDX ********************************
       COPY OPPSOUTM.

      ***************************************************************
      *   PREVIOUS YEAR WAGE INDEX LOOKUP TABLE                     *
      *-------------------------------------------------------------*
      *   TABLE IS NEW FOR CY 2020                                  *   00000300
      ***************************************************************
      ****** PREV-IDX ********************************
       COPY OPPSWI19.


      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **               WORKING-STORAGE DATA TABLES                 **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
      *                                                             *
      *   1) BLOOD DEDUCTIBLE RANKING TABLES (2013 - 2021)          *
      *                                                             *
      ***************************************************************



      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2013       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT EACH YEAR                         *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W13BD-INDX   *****************************

       01  W-2013-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P905401P902102P901003P905604P905105P901606'.
           03                          PIC X(42)  VALUE
              'P903807P904008P905809P902210P905711P903912'.
       01  W-2013-BLOOD-APC-TABLE REDEFINES W-2013-BLOOD-APC-FILLS.
           03 W13BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W13BD-INDX.
              05  W-2013-BLOOD-HCPCS       PIC X(05).
              05  W-2013-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2014       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT HCPCS AND/OR APC RATE ORDER       *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W14BD-INDX   *****************************

       01  W-2014-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P902101P905602P905103P901604P901005P903806'.
           03                          PIC X(42)  VALUE
              'P905407P904008P902209P905810P903911P905712'.
       01  W-2014-BLOOD-APC-TABLE REDEFINES W-2014-BLOOD-APC-FILLS.
           03 W14BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W14BD-INDX.
              05  W-2014-BLOOD-HCPCS       PIC X(05).
              05  W-2014-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2015       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT HCPCS AND/OR APC RATE ORDER       *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W15BD-INDX   *****************************

       01  W-2015-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P905601P902102P905103P901604P903805P901006'.
           03                          PIC X(42)  VALUE
              'P905407P905808P904009P902210P905711P903912'.
       01  W-2015-BLOOD-APC-TABLE REDEFINES W-2015-BLOOD-APC-FILLS.
           03 W15BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W15BD-INDX.
              05  W-2015-BLOOD-HCPCS       PIC X(05).
              05  W-2015-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2016       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT HCPCS AND/OR APC RATE ORDER       *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W16BD-INDX   *****************************

       01  W-2016-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P905601P902102P901603P905104P905705P903806'.
           03                          PIC X(42)  VALUE
              'P901007P905808P904009P902210P905411P903912'.
       01  W-2016-BLOOD-APC-TABLE REDEFINES W-2016-BLOOD-APC-FILLS.
           03 W16BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W16BD-INDX.
              05  W-2016-BLOOD-HCPCS       PIC X(05).
              05  W-2016-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2017       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT HCPCS AND/OR APC RATE ORDER       *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W17BD-INDX   *****************************

       01  W-2017-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P905601P902102P901003P901604P905105P905706'.
           03                          PIC X(42)  VALUE
              'P903807P905808P904009P905410P902211P903912'.
       01  W-2017-BLOOD-APC-TABLE REDEFINES W-2017-BLOOD-APC-FILLS.
           03 W17BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W17BD-INDX.
              05  W-2017-BLOOD-HCPCS       PIC X(05).
              05  W-2017-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2018       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT HCPCS AND/OR APC RATE ORDER       *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W18BD-INDX   *****************************

       01  W-2018-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P902101P905602P901003P901604P905105P903806'.
           03                          PIC X(42)  VALUE
              'P905807P904008P905709P905410P902211P903912'.
       01  W-2018-BLOOD-APC-TABLE REDEFINES W-2018-BLOOD-APC-FILLS.
           03 W18BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W18BD-INDX.
              05  W-2018-BLOOD-HCPCS       PIC X(05).
              05  W-2018-BLOOD-RANK        PIC 9(02).




      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2019       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT HCPCS AND/OR APC RATE ORDER       *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W19BD-INDX   *****************************

       01  W-2019-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P901001P902102P905103P901604P903805P905706'.
           03                          PIC X(42)  VALUE
              'P905607P905808P904009P905410P903911P902212'.
       01  W-2019-BLOOD-APC-TABLE REDEFINES W-2019-BLOOD-APC-FILLS.
           03 W19BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W19BD-INDX.
              05  W-2019-BLOOD-HCPCS       PIC X(05).
              05  W-2019-BLOOD-RANK        PIC 9(02).




      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2020       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT HCPCS AND/OR APC RATE ORDER       *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W20BD-INDX   *****************************

       01  W-2020-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P901001P902102P905103P901604P903805P905606'.
           03                          PIC X(42)  VALUE
              'P905707P905808P904009P905410P903911P902212'.
       01  W-2020-BLOOD-APC-TABLE REDEFINES W-2020-BLOOD-APC-FILLS.
           03 W20BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W20BD-INDX.
              05  W-2020-BLOOD-HCPCS       PIC X(05).
              05  W-2020-BLOOD-RANK        PIC 9(02).




      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2021       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT HCPCS AND/OR APC RATE ORDER       *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W21BD-INDX   *****************************

       01  W-2021-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P902101P901002P905603P903804P901605P905106'.
           03                          PIC X(42)  VALUE
              'P905807P904008P905709P905410P902211P903912'.
       01  W-2021-BLOOD-APC-TABLE REDEFINES W-2021-BLOOD-APC-FILLS.
           03 W21BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W21BD-INDX.
              05  W-2021-BLOOD-HCPCS       PIC X(05).
              05  W-2021-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **               MISCELLANEOUS WORK VARIABLES                **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
       01  WORK-AREA.
           05  H-SUB                   PIC S9(07) COMP-3  VALUE ZERO.
           05  W-SUB1                  PIC S9(07) COMP-3  VALUE ZERO.
           05  W-SUB2                  PIC S9(07) COMP-3  VALUE ZERO.
           05  W-SUB3                  PIC S9(07) COMP-3  VALUE ZERO.
           05  PS-SUB                  PIC S9(07) COMP-3  VALUE ZERO.
           05  LN-SUB                  PIC S9(07) COMP-3  VALUE ZERO.
           05  DISC-FRACTION           PIC 9V9(03)  VALUE .500.
           05  TERM-PROC-DISC          PIC 9V9(03)  VALUE .500.
           05  CT-REDUCT-2016          PIC 9V9(03)  VALUE 0.950.
           05  CT-REDUCT-2017          PIC 9V9(03)  VALUE 0.850.
           05  XRAY-FILM-REDUCT-2017   PIC 9V9(03)  VALUE 0.800.
           05  XRAY-CRT-REDUCT-2018    PIC 9V9(03)  VALUE 0.930.
           05  PFS-REDUCT-2017         PIC 9V9(03)  VALUE 0.500.
           05  PFS-REDUCT-2018         PIC 9V9(03)  VALUE 0.400.
           05  PMF-A-REDUCT-2019       PIC 9V9(03)  VALUE 0.700.
           05  PMF-A-REDUCT-2020       PIC 9V9(03)  VALUE 0.400.
           05  COIN-RATE-20            PIC 9V9(02)  VALUE 0.20.
           05  PFS-REIM-RATE           PIC 9V9(02)  VALUE 0.80.
           05  CMHC-OUTL-CAP-PCT       PIC 9V9(02)  VALUE 0.08.
           05  WI-QUARTILE-CY2020      PIC 9(02)V9(04) VALUE 0.8457.
           05  WI-QUARTILE-CY2021      PIC 9(02)V9(04) VALUE 0.8469.
           05  WI-PCT-REDUCT-CY2020    PIC S9(01)V9(02) VALUE -0.05.
           05  WI-PCT-ADJ-CY2020       PIC 9(01)V9(02) VALUE 0.95.
           05  APC33-FLAG              PIC X(01).
      *----------------------------------------------*
      * 11/03/2008 - PHP APC FLAG ADDED              *
      *----------------------------------------------*
           05  PHP-APC-FLAG            PIC X(01).
      *----------------------------------------------*
      * 11/28/2007 - APC 34 FLAG ADDED               *
      *----------------------------------------------*
           05  APC34-FLAG              PIC X(01).
      *----------------------------------------------*
      * 05/12/2009 - APC 34 COUNTER ADDED            *
      *----------------------------------------------*
           05  W-APC34-CNT             PIC 9(03).
           05  C1820-OFFSET-FLAG       PIC X(01).
           05  GJK-FLAG                PIC X(01).
           05  BLOOD-FLAG              PIC X(01).
           05  ST0-FLAG                PIC X(01).
           05  N-FLAG                  PIC X(01).
           05  C-FLAG                  PIC X(01).
           05  T-LITEM-PYMT            PIC S9(07)V9(02).
           05  W-OFF-APC               PIC X(05).
      *--------------------------------------------------*
      * 11/5/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED *
      *--------------------------------------------------*
           05  PHP-HCPCS-FLAG          PIC X(01).
           05  MH-HCPCS-FLAG           PIC X(01).
      *--------------------------------------------------*
      * 11/6/2007 - BRACHYTHERAPY APC FLAG ADDED         *
      *--------------------------------------------------*
           05  BRACHY-APC-FLAG         PIC X(01).
      *--------------------------------------------------*
      * 12/27/2007 - RADIOPHARM APC FLAG ADDED           *
      *--------------------------------------------------*
           05  RADIOPH-APC-FLAG         PIC X(01).
      *-------------------------------------------------------------*
      * 11/13/2007 - BLOOD HCPCS SUBJECT TO BLOOD DEDUC. FLAG ADDED *
      *-------------------------------------------------------------*
           05  BLD-DEDUC-HCPCS-FLAG    PIC X(01).
      *-------------------------------------------------------------*
      * 02/11/2008 - PASS-THROUGH DEVICE FLAGS ADDED                *
      *-------------------------------------------------------------*
           05  PTD-FLAG                PIC X(01).
           05  PTD-LINE-FLAG           PIC X(01).
           05  PTD-PROC-FLAG           PIC X(01).
      *-------------------------------------------------------------*
      * 02/13/2008 - ADDED W-PTD VARIABLES FOR PASS-THROUGH DEVICES *
      *-------------------------------------------------------------*
           05  W-PTD-LINE-HCPCS        PIC X(05).
           05  W-PTD-CNT               PIC 9(03).
           05  W-PTD-PROC-SUB          PIC 9(03).
           05  W-END-OF-PTD-TBL        PIC X(01).
      *-------------------------------------------------------------*
      * 02/10/2009 - VARIABLES FOR PASS-THROUGH RADIOPHARM LOGIC    *
      *-------------------------------------------------------------*
           05  PTRADIO-CLAIM-FLAG      PIC X(01).
           05  PTRADIO-LINE-FLAG       PIC X(01).
           05  W-PTRADIO-LINE-HCPCS    PIC X(05).
           05  W-PTRADIO-CHRG-RATE     PIC 9(01)V9(8).
           05  W-PTRADIO-LINE-OFFSET   PIC 9(07)V99.
           05  NUCMED-LINE-FLAG        PIC X(01).
           05  W-NUCMED-LINE-APC       PIC X(05).
           05  W-NUCMED-SUB            PIC 9(03).
           05  W-NUCMED-UNIT-CNT       PIC 9(03).
           05  W-END-OF-NUCMED-TBL     PIC X(01).
           05  W-NUCMED-OFFSET         PIC 9(07)V99.
           05  W-NUCMED-WA-OFFSET      PIC 9(07)V99.
           05  W-LINE-SRVC-DATE.
               10  W-LINE-SRVC-YEAR    PIC 9(04).
               10  W-LINE-SRVC-MONTH   PIC 9(02).
               10  W-LINE-SRVC-DAY     PIC 9(02).
      *-------------------------------------------------------------*
      * 05/12/2009 - ADDED TO IDENTIFY BLOOD HCPCS FOR 2005 - 2008  *
      *-------------------------------------------------------------*
           05 W-BLD-HCPCS-FLAG         PIC X(01).
      *-------------------------------------------------------------*
      * 11/15/2009 - VARIABLES FOR PASS-THROUGH CONTRAST AGENT LOGIC*
      *-------------------------------------------------------------*
           05  PTCA-CLAIM-FLAG         PIC X(01).
           05  PTCA-LINE-FLAG          PIC X(01).
           05  W-PTCA-LINE-HCPCS       PIC X(05).
           05  W-PTCA-CHRG-RATE        PIC 9(01)V9(8).
           05  W-PTCA-LINE-OFFSET      PIC 9(07)V99.
           05  W-CAPROC-LINE-APC       PIC X(05).
           05  W-CAPROC-SUB            PIC 9(03).
           05  W-CAPROC-UNIT-CNT       PIC 9(03).
           05  W-CAPROC-OFFSET         PIC 9(07)V99.
           05  W-CAPROC-KEY.
               10  W-CAPROC-SRVC-DATE.
                   15  W-CAPROC-SRVC-YEAR  PIC 9(04).
                   15  W-CAPROC-SRVC-MONTH PIC 9(02).
                   15  W-CAPROC-SRVC-DAY   PIC 9(02).
               10  W-CAPROC-WA-OFFSET      PIC 9(07)V99.
      *-------------------------------------------------------------*
      * 08/02/2010 - VARIABLES FOR PASS-THROUGH DEVICE OFFSET LOGIC *
      *-------------------------------------------------------------*
           05  PTDO-CLAIM-FLAG         PIC X(01).
           05  PTDO-LINE-FLAG          PIC X(01).
           05  W-PTDO-LINE-HCPCS       PIC X(05).
           05  W-PTDO-CHRG-RATE        PIC 9(01)V9(8).
           05  W-PTDO-LINE-OFFSET      PIC 9(07)V99.
           05  W-PTDO-EOF-SWITCH       PIC X.
           05  W-DOPROC-LINE-APC       PIC X(05).
           05  W-DOPROC-SUB            PIC 9(03).
           05  W-DOPROC-UNITS          PIC 9(09).
           05  W-DOPROC-OFFSET         PIC 9(07)V99.
           05  W-DOPROC-KEY.
               10  W-DOPROC-SRVC-DATE.
                   15  W-DOPROC-SRVC-YEAR  PIC 9(04).
                   15  W-DOPROC-SRVC-MONTH PIC 9(02).
                   15  W-DOPROC-SRVC-DAY   PIC 9(02).
               10  W-DOPROC-WA-OFFSET      PIC 9(07)V99.
      *----------------------------------------------*
      * 05/09/2011 - BILL TYPE 14X FLAG ADDED        *
      * 02/07/2012 - BILL TYPE 14X FLAG REMOVED      *
      *----------------------------------------------*
      *    05  BILL14X-FLAG            PIC X(01).
      *----------------------------------------------*
      * 11/19/2013 - DEVICE CREDIT CLAIM FLAG ADDED  *
      *----------------------------------------------*
           05  DEVCR-CLAIM-FLAG        PIC X(01).
      *----------------------------------------------*
      * 11/13/2014 - DATE CODE HOLD VARIABLE         *
      *----------------------------------------------*
           05  W-WCW-DTCD              PIC S9(07) COMP-3  VALUE ZERO.
      *----------------------------------------------*
      * 05/04/2016 - COMPREHENSIVE APC CLAIM FLAG    *
      *----------------------------------------------*
           05  C-APC-CLAIM-FLAG        PIC X(01).
      *----------------------------------------------*
      * 05/09/2016 - PACKAGED BLOOD DEDUCTIBLE LINE  *
      *----------------------------------------------*
           05  PKG-BLD-DED-LINE-FLAG   PIC X(01).
               88 PKG-BLD-DED-LINE       VALUE 'Y'.


       01  EIGHTY-8-SWS.
           05  GEO-CBSA-FLAG           PIC X(5).
               88 RURAL-GEO              VALUE '   01' THRU '   99'.
           05  WI-CBSA-FLAG            PIC X(5).
               88 RURAL-WI               VALUE '   01' THRU '   99'.
           05  PYMT-CBSA-FLAG          PIC X(5).
               88 RURAL-PYMT             VALUE '   01' THRU '   99'.

      *-------------------------------------------------------------*
      * VARIABLES TO HOLD THE BILL'S CALENDAR YR BEGIN & END DATES  *
      * ADDED SECTION 10/23/2014 FOR WAGE INDEX SELECTION LOGIC     *
      *-------------------------------------------------------------*
       01  W-CY-BEGIN-DATE.
               05  W-CY-BEGIN-YYYY            PIC 9(04).
               05  W-CY-BEGIN-MM              PIC 9(02) VALUE 01.
               05  W-CY-BEGIN-DD              PIC 9(02) VALUE 01.

       01  W-CY-END-DATE.
               05  W-CY-END-YYYY              PIC 9(04).
               05  W-CY-END-MM                PIC 9(02) VALUE 12.
               05  W-CY-END-DD                PIC 9(02) VALUE 31.


      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **   BELOW ARE THE VARIABLES THAT WILL BE HELD FOR CLAIM     **
      **   LEVEL PROCESSING (OUTLIER/DEDUCTIBLE/COINSURANCE)       **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
       01  H-ADDITIONAL-VARIABLES.
           05  H-OUTLIER-PYMT             PIC S9(07)V9(02).
           05  H-PRTL-HOSP-PYMT           PIC 9(07)V9(02).
           05  H-TOTAL-CLM-DEDUCT         PIC 9(03)V9(02).
           05  H-TOTAL-OFFSET             PIC S9(07)V9(02).
           05  H-TOTAL-WAOFF              PIC 9(07)V9(02).
           05  H-TOT-CHRG                 PIC 9(07)V9(02).
           05  H-TOT-PYMT                 PIC 9(07)V9(02).
           05  H-BENE-DEDUCT              PIC 9(03)V9(02).
           05  H-MAX-COIN                 PIC 9(07)V9(02).
           05  H-IP-LIMIT                 PIC 9(05)V9(02).
           05  H-NEW-COIN                 PIC 9(05)V9(02).
           05  H-NEW-WGNAT                PIC 9(05)V9(02).
           05  H-BLOOD-DEDUCT-DUE         PIC 9(05)V9(02).
           05  H-TOT-ST-CHRG              PIC 9(08)V99.
           05  H-TOT-N-CHRG               PIC 9(08)V99.
           05  H-TOT-H-CHRG               PIC 9(08)V99.
      *-------------------------------------------------------------*
      * 11/28/2007 - TOTAL MENTAL HEALTH CHARGES ADDED              *
      *-------------------------------------------------------------*
           05  H-TOT-MH-CHRG              PIC 9(08)V99.
           05  H-TOT-38X                  PIC 9(08)V99.
           05  H-TOT-38X-39X              PIC 9(08)V99.
           05  H-38X-39X-RATE             PIC 9(01)V9(04).
           05  H-TOT-ST-PYMT              PIC 9(08)V99.
           05  H-TOT-STVX-PYMT            PIC 9(08)V99.
           05  H-TOT-HTD-UNITS            PIC S9(09).
           05  H-TOT-OFF-UNITS            PIC S9(09).
           05  H-BENE-BLOOD-PINTS         PIC 9(01).
           05  H-BENE-PINTS-USED          PIC 9(01).
      *-------------------------------------------------------------*
      * 02/10/2009 - VARIABLES FOR PASS-THROUGH RADIOPHARM LOGIC    *
      *-------------------------------------------------------------*
           05  H-PTRADIO-TOT-CHRGS      PIC 9(08)V99.
           05  H-NUCMED-TOT-OFFSET      PIC 9(08)V99.
           05  H-PTRADIO-HCPCS-CNT      PIC 9(03).
      *-------------------------------------------------------------*
      * 11/18/2013 - CLAIM LEVEL VARIABLE FOR DEVICE CREDIT ADDED   *
      * 02/09/2016 - CLAIM LEVEL VARIABLE FOR DEVICE CREDIT ADDED   *
      *-------------------------------------------------------------*
           05  H-TOT-DEVCR-PYMTS        PIC 9(08)V99.
           05  H-CLAIM-DEVCR-AMT        PIC 9(08)V99.
      *-------------------------------------------------------------*
      * 11/13/2008 - ADDED VARIABLE FOR PHP APC PAYMENTS            *
      * 04/04/2014 - MOVED VARIABLE OUT OF LINE-HOLD-ITEMS - CANNOT *
      *              BE UNDER LINE-HOLD-ITEMS BECAUSE IT WILL BE    *
      *              ZEROED OUT BEFORE BEING USED IN THE OUTLIER    *
      *              ROUTINE.                                       *
      *-------------------------------------------------------------*
           05 H-PHP-LITEM-PYMT-OUTL   PIC 9(07)V99.
      *-------------------------------------------------------------*
      * 11/13/2015 - CLAIM VARIABLES FOR NEW PT DEVICE OFFSET LOGIC *
      *-------------------------------------------------------------*
           05 H-QN-TOT-PTD-CHARGES    PIC 9(08)V99.
           05 H-QO-TOT-PTD-CHARGES    PIC 9(08)V99.
      *    05 H-QP-TOT-PTD-CHARGES    PIC 9(08)V99.
           05 H-QN-WA-PTD-OFFSET      PIC 9(08)V99.
           05 H-QO-WA-PTD-OFFSET      PIC 9(08)V99.
      *    05 H-QP-WA-PTD-OFFSET      PIC 9(08)V99.
      *-------------------------------------------------------------*
      * 02/09/2016 - CLAIM VARIABLES FOR TERM. PROC DEVICE OFFSET   *
      *-------------------------------------------------------------*
           05 H-TOT-TPDO-PYMTS        PIC 9(08)V99.
           05 H-WA-TPDO-OFFSET        PIC 9(08)V99.
      *-------------------------------------------------------------*
      * 02/15/2017 - CLAIM VARIABLES FOR CMHC W/PHP FOR OUTLIER CAP *
      *-------------------------------------------------------------*
           05 H-CMHC-OUTLIER-PCT       PIC 9(03)V9(02).
           05 H-CMHC-PYMT-TOTAL        PIC 9(11)V9(02).
           05 H-CMHC-OUTL-TOTAL        PIC 9(11)V9(02).
      *-------------------------------------------------------------*
      * 06/05/2017 - OUTMIGRATION ADJUSTMENT LOGIC VARIABLES        *
      *-------------------------------------------------------------*
           05 OUTM-IND                 PIC 9(01).
           05 OUTM-IDX2                PIC 9(04).
           05 HLD-OUTM-ADJ             PIC 9(01)V9(04).

      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **   BELOW ARE THE VARIABLES THAT WILL BE HELD FOR LINE      **
      **                      LEVEL PROCESSING                     **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
           05  LINE-HOLD-ITEMS.
              10  H-COIN-PERCENT          PIC 9(01)V9(04).
              10  H-LITEM-PYMT            PIC S9(07)V9(02).
              10  H-LITEM-OUTL-PYMT       PIC S9(07)V9(02).
              10  H-COST                  PIC S9(07)V9(02).
              10  H-LITEM-REIM            PIC 9(07)V9(02).
              10  H-SCH-PYMT              PIC 9(07)V9(02).
              10  H-APC-PYMT              PIC 9(07)V9(02).
              10  H-APC-ADJ-PYMT          PIC 9(07)V9(02).
              10  H-TOTAL-LN-DEDUCT       PIC 9(03)V9(02).
              10  H-LN-BLOOD-DEDUCT       PIC 9(05)V9(02).
              10  H-LN-BLD-PYMT           PIC 9(05)V9(02).
              10  H-NAT-COIN              PIC 9(07)V9(02).
              10  H-MIN-COIN              PIC 9(05)V9(02).
              10  H-PSF-COIN              PIC 9(05)V9(02).
              10  H-RED-COIN              PIC 9(05)V9(02).
              10  H-RATIO                 PIC S9(07)V9(07).
              10  H-SHIFT                 PIC 9(05)V9(02).
              10  H-TOTAL                 PIC 9(05)V9(02).
              10  H-OUTLIER-FACTOR        PIC 9(01)V9(02).
              10  H-OUTLIER-PCT           PIC 9(01)V9(02).
              10  H-LN-PTR                PIC 9(03).
              10  H-SRVC-UNITS            PIC 9(09).
              10  H-RANK                  PIC 9(05).
              10  H-BLD-RNK.
                15  H-BLD-DOS             PIC 9(08).
                15  H-BLOOD-RANK          PIC 9(02).
      *-------------------------------------------------------------*
      * 11/28/2007 - ADDED PAF FOR COMPOSITE LINES                  *
      * 11/12/2008 - ADDED CAF FOR COMPOSITE LINES (COMP ADJ FLAG)  *
      *-------------------------------------------------------------*
              10  H-CMP-PAF               PIC 9(02).
              10  H-CMP-CAF               PIC 9(02).
              10  H-PSF-MSA               PIC X(04).
              10  H-PSF-CBSA              PIC X(05).
              10  H-DCP-STAGE.
                15  H-DCP-DOS             PIC 9(08).
                15  H-DCP-CODE            PIC 9(01).
              10  H-PPCT                  PIC S9V9(06) COMP-3.
              10  H-DISC-RATE             PIC S9V9(08) COMP-3.
              10  H-BLOOD-FRACTION        PIC S9V9(08) COMP-3.
              10  H-WINX                  PIC S9V9(04) COMP-3.
              10  H-PREV-WINX             PIC S9V9(04) COMP-3.
              10  H-SUB-CHRG              PIC 9(08)V99.
              10  H-CHRG-RATE             PIC 9(01)V9(8).
              10  H-OFF-RATE              PIC 9(01)V9(8).
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED W-PTD VARIABLES FOR PASS-THROUGH DEVICES *
      *-------------------------------------------------------------*
              10  H-PTD-UNIT-RATE         PIC 9(01)V9(8).
              10  H-PTD-SUB-CHRG          PIC 9(08)V99.
              10  H-PTD-LITEM-PYMT        PIC 9(07)V99.
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED H-LITEM-PYMT-OUTL FOR OUTLIER CALC       *
      *-------------------------------------------------------------*
              10 H-LITEM-PYMT-OUTL        PIC 9(07)V99.
      *-------------------------------------------------------------*
      * 11/16/2009 - ADDED H-PTCA-LIDOS FOR PT CONTRAST AGENT LOGIC *
      *-------------------------------------------------------------*
              10 H-PTCA-LIDOS             PIC 9(08).
      *-------------------------------------------------------------*
      * 08/02/2010 - ADDED VARIBLES FOR NEW PT DEVICE OFFSET LOGIC  *
      *-------------------------------------------------------------*
              10 H-PTDO-CHRGUNIT.
                 15 H-PTDO-CHRG           PIC 9(08)V99.
                 15 H-PTDO-UNITS          PIC 9(09).
              10 H-PTDO-ASSOC-HCPCS-CTR   PIC 9(03).
              10 H-PTDO-PROC-KEY.
                 15 H-PTDO-PROC-WA-OFFSET PIC 9(08)V99.
                 15 H-PTDO-PROC-UNITS     PIC 9(09).
      *-------------------------------------------------------------*
      * 11/18/2013 - LINE LEVEL VARIABLES FOR DEVICE CREDIT ADDED   *
      *-------------------------------------------------------------*
              10 H-LINE-DEVCR-PYMT-RATE   PIC 9(01)V9(04).
              10 H-LINE-DEVCR-AMT         PIC 9(07)V99.
      *-------------------------------------------------------------*
      * 11/13/2015 - LINE VARIABLES FOR NEW PT DEVICE OFFSET LOGIC  *
      *-------------------------------------------------------------*
              10 H-TOT-PTD-CHARGES        PIC 9(08)V99.
              10 H-WA-PTD-OFFSET          PIC 9(08)V99.
      *-------------------------------------------------------------*
      * 02/09/2016 - LINE VARIABLES FOR TERM. PROC DEVICE OFFSET    *
      *-------------------------------------------------------------*
              10 H-LINE-TPDO-PYMT-RATE    PIC 9(01)V9(04).
              10 H-LINE-TPDO-AMT          PIC 9(07)V99.

      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **     WORKING-STORAGE TABLES TO BE POPULATED IN PROGRAM     **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
      *                                                             *
      *   1) COINSURANCE DEDUCTIBLE TABLE (TO HOLD CLAIM LINES)     *
      *   2) BLOOD DEDUCTIBLE TABLE (TO HOLD BLOOD DEDUCTIBLE LINES)*
      *   3) COINSURANCE CAP ROLL-UP TABLE                          *
      *   4) PACKAGED COMPOSITE CHARGES TABLE                       *
      *   5) PASS-THROUGH DEVICE TABLE                              *
      *   6) PASS-THROUGH DEVICE PROCEDURE TABLE                    *
      *   7) NUCLEAR MEDICINE APC TABLE (FOR PT RADIOPHARM LOGIC)   *
      *   8) PASS-THROUGH CONTRAST AGENT DAILY SUMMARY TABLE        *
      *   9) PASS-THROUGH CONTRAST AGENT PROCEDURE APC TABLE        *
      *                                                             *
      ***************************************************************


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE TO PROCESS DEDUCTIBLES.         *
      *-------------------------------------------------------------*
      *   THIS TABLE RANKS APC LOW PAYMENT TO HIGH PAYMENT %        *
      *   TABLE TO RANK PRICE DEDUCTIBLES.                          *
      *                                                             *
      ***************************************************************
      ****** W-LP-INDX  ******************************

       01  W-LNC-MAX                      PIC S9(07)  COMP-3 VALUE +0.

       01  W-LINE-PTR-TABLE.
          05  W-LP-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-LNC-MAX
                ASCENDING KEY IS W-RANK
                INDEXED BY W-LP-INDX.
              10  W-LP-SUB                PIC S9(07)   COMP-3.
              10  W-APC-PYMT              PIC 9(07)V99.
              10  W-NAT-COIN              PIC 9(05)V99.
              10  W-MIN-COIN              PIC 9(05)V99.
              10  W-RED-COIN              PIC 9(04)V99.
              10  W-DISC-RATE             PIC 9(01)V9(08).
              10  W-SRVC-UNITS            PIC 9(09).
              10  W-RANK                  PIC 9(05).
              10  W-PPCT                  PIC S9V9(06) COMP-3.
              10  W-WINX                  PIC S9V9(04) COMP-3.
              10  W-SUB-CHRG              PIC 9(08)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE TO PROCESS BLOOD DEDUCTIBLES    *
      *-------------------------------------------------------------*
      *   RANK BLOOD DEDUCTIBLE TO DETERMINE LOWEST PRICE FOR       *   00000300
      *   BENE TO PAY.                                              *   00000400
      *                                                             *   00000500
      *   IF PINTS REMAINING, THIS DETERMINES THE CHEAPEST UNIT     *   00000500
      *   FOR BENE TO PAY.                                          *   00000500
      ***************************************************************   00000600
      ****** W-BD-INDX  ******************************

       01  W-BLD-MAX                      PIC S9(07)  COMP-3 VALUE +0.
       01  W-BLOOD-PTR-TABLE.
          05  W-BD-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-BLD-MAX
                INDEXED BY W-BD-INDX.
              10  W-BD-SUB                PIC S9(07)   COMP-3.
              10  W-BD-APC-PYMT           PIC 9(07)V99.
              10  W-BD-NAT-COIN           PIC 9(05)V99.
              10  W-BD-MIN-COIN           PIC 9(05)V99.
              10  W-BD-RED-COIN           PIC 9(04)V99.
              10  W-BD-DISC-RATE          PIC 9(01)V9(08).
              10  W-BD-SRVC-UNITS         PIC 9(09).
              10  W-BD-RNK.
                  15  W-BD-DOS            PIC 9(08).
                  15  W-BD-RANK           PIC 9(02).
              10  W-BD-PPCT               PIC S9V9(06) COMP-3.
              10  W-BD-WINX1              PIC S9V9(04) COMP-3.
              10  W-BD-SUB-CHRG           PIC 9(08)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE TO PROCESS COINSURANCE CAP      *
      *   ROLL-UP                                                   *
      ***************************************************************
      ****** W-DCP-INDX  ******************************

       01  W-DCP-MAX                      PIC S9(07)  COMP-3 VALUE +0.
       01  W-DOS-COIN-PTR-TABLE.
          05  W-DCP-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-DCP-MAX
                ASCENDING KEY IS W-DCP-STAGE
                INDEXED BY W-DCP-INDX.
              10  W-DCP-SUB               PIC S9(07).
              10  W-DCP-STAGE.
                 15  W-DCP-DOS            PIC 9(08).
                 15  W-DCP-CODE           PIC 9(01).
              10  W-DCP-SRVC-IND          PIC X(02).
              10  W-DCP-COIN1             PIC 9(05)V99.
              10  W-DCP-COIN2             PIC 9(05)V99.
              10  W-DCP-WGNAT             PIC 9(05)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE TO ACCUMULATE COMPOSITE APC     *
      *   NON-PRIME LINE CHARGES                                    *
      *   NEW FOR JANUARY 2008                                      *
      ***************************************************************
      ****** W-CMP-INDX  ******************************

       01  W-CMP-MAX                      PIC S9(07)  COMP-3 VALUE +0.
       01  W-COMPOSITE-PTR-TABLE.
          05  W-CMP-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-CMP-MAX
                ASCENDING KEY IS W-CMP-PAF
                INDEXED BY W-CMP-INDX.
              10  W-CMP-PAF               PIC 9(02).
              10  W-CMP-TOT-SUB-CHRG      PIC 9(10)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR PASS-THROUGH DEVICES        *
      *   NEW FOR APRIL 2008                                        *
      ***************************************************************
      ****** W-PTD-INDX  *****************************

       01  W-PTD-MAX                      PIC S9(07)  COMP-3 VALUE +0.
       01  W-PASS-THRU-DEV-PTR-TABLE.
          05  W-PTD-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-PTD-MAX
                ASCENDING KEY IS W-PTD-HCPCS
                INDEXED BY W-PTD-INDX.
              10  W-PTD-HCPCS             PIC X(05).
              10  W-PTD-SUB               PIC S9(07)   COMP-3.
              10  W-PTD-SUB-CHRG          PIC 9(08)V99.
              10  W-PTD-LITEM-PYMT        PIC 9(07)V99.
              10  W-PTD-TOTAL-PROC-UNITS  PIC 9(03).
              10  W-PTD-PROC-CNT          PIC 9(03).


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR PASS-THROUGH DEVICE PROCS   *
      *   NEW FOR APRIL 2008                                        *
      *   02/11/2009 - CHANGED OCCURS FROM 999 TO '0 TO 450' TIMES  *
      ***************************************************************

       01  W-PTD-PROC-HCPCS-TBL.
           05  W-PTD-PROC-HCPCS-ENTRY OCCURS 0 TO 450 TIMES
                 DEPENDING ON W-PTD-CNT.
               10 W-PTD-PROC-HCPCS     PIC X(05).


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR NUCLEAR MEDICINE APCS       *
      *                                                             *
      *   THIS TABLE HOLDS A NUCLEAR MEDICINE APC RECORD WITH ITS   *
      *   WAGE ADJUSTED OFFSET AMOUNT FOR EVERY NUCLEAR MEDICINE    *
      *   UNIT ON THE CLAIM WHEN A PASS-THROUGH RADIOPHARM HCPCS    *
      *   IS ALSO ON THE CLAIM.                                     *
      *   NEW FOR APRIL 2009 - TABLE ADDED 02/10/2009               *
      *                                                             *
      ***************************************************************
      ****** W-NUCMED-INDX ***************************

       01  W-NUCMED-MAX                    PIC S9(07)  COMP-3 VALUE +0.
       01  W-NUCMED-APC-TBL.
           05  W-NUCMED-APC-ENTRY OCCURS 0 TO 450 TIMES
                 DEPENDING ON W-NUCMED-MAX
                 INDEXED BY W-NUCMED-INDX.
               10 W-NUCMED-APC             PIC X(05).
               10 W-NUCMED-WAGE-ADJ-OFFSET PIC 9(07)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR THE PASS-THROUGH CONTRAST   *
      *   AGENT DAILY SUMMARY                                       *
      *   NEW FOR JANUARY 2010 - TABLE ADDED 11/15/2009             *
      *                                                             *
      *   THIS TABLE HOLDS A PT CONTRAST AGENT DAY RECORD WITH ITS  *
      *   DATE OF SERVICE, PT CONTRAST AGENT HCPCS COUNT, TOTAL     *
      *   CONTRAST CHARGES, AND TOTAL CONTRAST PROCEDURE OFFSET.  A *
      *   DAY RECORD IS CREATED WHEN A PT CONTRAST AGENT HCPCS      *
      *   LINE FALLS ON THE DATE OF SERVICE.                        *
      *                                                             *
      ***************************************************************
      ****** W-PTCA-DAY-INDX *************************

       01  W-PTCA-DAY-MAX                  PIC S9(07)  COMP-3 VALUE +0.
       01  W-PTCA-DAY-TBL.
           05  W-PTCA-DAY-ENTRY OCCURS 0 TO 450 TIMES
                 DEPENDING ON W-PTCA-DAY-MAX
                 INDEXED BY W-PTCA-DAY-INDX.
               10 W-PTCA-DAY-LIDOS      PIC 9(08).
               10 W-PTCA-DAY-HCPCS-CNT  PIC 9(03).
               10 W-PTCA-DAY-TOT-CHRGS  PIC 9(08)V99.
               10 W-PTCA-DAY-TOT-OFFSET PIC 9(08)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR PASS-THROUGH CONTRAST AGENT *
      *                        PROCEDURE APCS                       *
      *                                                             *
      *   THIS TABLE HOLDS A PASS-THROUGH CONTRAST AGENT PROCEDURE  *
      *   APC RECORD WITH ITS WAGE ADJUSTED OFFSET AMOUNT AND LINE  *
      *   ITEM DATE OF SERVICE (LIDOS) FOR EACH CONTRAST AGENT      *
      *   PROCEDURE ON THE CLAIM WITH A LIDOS THAT MATCHES THE      *
      *   LIDOS ON A PASS-THROUGH CONTRAST AGENT LINE.              *
      *   NEW FOR JANUARY 2010 - TABLE ADDED 11/15/2009             *
      *                                                             *
      ***************************************************************
      ****** W-CAPROC-INDX ***************************

       01  W-CAPROC-MAX                    PIC S9(07)  COMP-3 VALUE +0.
       01  W-CAPROC-APC-TBL.
           05  W-CAPROC-APC-ENTRY OCCURS 0 TO 450 TIMES
                 DEPENDING ON W-CAPROC-MAX
                 INDEXED BY W-CAPROC-INDX.
               10 W-CAPROC-TBL-KEY.
                  15 W-CAPROC-LIDOS           PIC 9(8).
                  15 W-CAPROC-WAGE-ADJ-OFFSET PIC 9(07)V99.
               10 W-CAPROC-APC                PIC X(05).


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR THE PASS-THROUGH DEVICE     *
      *   HCPCS (FOR REVISED PASS-THROUGH DEVICE OFFSET LOGIC)      *
      *   NEW FOR OCT 2010 - TABLE ADDED 08/04/2010                 *
      *                                                             *
      *   THIS TABLE HOLDS A PT DEVICE HCPCS RECORD FOR EACH PT     *
      *   DEVICE HCPCS LINE ON THE CLAIM.  EACH RECORD HOLDS THE    *
      *   DEVICE'S HCPCS, LINE SUBSCRIPT, LINE UNITS, SUBMITTED     *
      *   CHARGE, NUMBER OF ASSOC. OFFSET PROCEDURE LINES ON CLAIM, *
      *   ITS ASSIGNED OFFSET PROCEDURE APC, AND ITS ASSIGNED       *
      *   OFFSET PROCEDURE APC'S LINE SUBSCRIPT.                    *
      *                                                             *
      ***************************************************************
      ****** W-PTDO-HCPCS-INDX ***********************

       01  W-PTDO-HCPCS-MAX               PIC S9(07)  COMP-3 VALUE +0.
       01  W-PTDO-HCPCS-TBL.
           05  W-PTDO-HCPCS-ENTRY OCCURS 0 TO 450 TIMES
                 DEPENDING ON W-PTDO-HCPCS-MAX
                 INDEXED BY W-PTDO-HCPCS-INDX.
               10 W-PTDO-HCPCS-HCPCS      PIC X(05).
               10 W-PTDO-HCPCS-LNSUB      PIC S9(07)   COMP-3.
               10 W-PTDO-HCPCS-CHRGUNIT.
                  15 W-PTDO-HCPCS-SUB-CHRG   PIC 9(08)V99.
                  15 W-PTDO-HCPCS-UNITS      PIC 9(09).
               10 W-PTDO-HCPCS-PROC-CNT   PIC 9(03).
               10 W-PTDO-HCPCS-PROC-APC   PIC X(05).
               10 W-PTDO-HCPCS-PROC-LNSUB PIC S9(07)   COMP-3.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR THE PASS-THROUGH DEVICE     *
      *   PROCEDURES (FOR REVISED PASS-THROUGH DEVICE OFFSET LOGIC) *
      *   NEW FOR OCT 2010 - TABLE ADDED 08/04/2010                 *
      *                                                             *
      *   THIS TABLE HOLDS A PT DEVICE HCPCS RECORD FOR EACH PT     *
      *   DEVICE HCPCS LINE ON THE CLAIM.  EACH RECORD HOLDS THE    *
      *   DEVICE'S HCPCS, LINE SUBSCRIPT, LINE UNITS, SUBMITTED     *
      *   CHARGE, NUMBER OF ASSOC. OFFSET PROCEDURE LINES ON CLAIM, *
      *   ITS ASSIGNED OFFSET PROCEDURE APC, AND ITS ASSIGNED       *
      *   OFFSET PROCEDURE APC'S LINE SUBSCRIPT.                    *
      *                                                             *
      ***************************************************************
      ****** W-PTDO-PROC-INDX ************************

       01  W-PTDO-PROC-MAX               PIC S9(07)  COMP-3 VALUE +0.
       01  W-PTDO-DARRAY-MAX             PIC S9(07)  COMP-3 VALUE +0.
       01  W-PTDO-PROC-TBL.
           05  W-PTDO-PROC-ENTRY OCCURS 0 TO 450 TIMES
                 DEPENDING ON W-PTDO-PROC-MAX
                 INDEXED BY W-PTDO-PROC-INDX.
               10 W-PTDO-PROC-APC        PIC X(05).
               10 W-PTDO-PROC-LNSUB      PIC S9(07)   COMP-3.
               10 W-PTDO-PROC-KEY.
                   15 W-PTDO-PROC-WA-OFFSET  PIC 9(08)V99.
                   15 W-PTDO-PROC-UNITS      PIC 9(09).
               10 W-PTDO-PROC-DEVICE-CNT PIC 9(03).
               10 W-PTDO-PROC-DARRAY OCCURS 0 TO 450 TIMES
                    DEPENDING ON W-PTDO-DARRAY-MAX
                    INDEXED BY W-PTDO-DARRAY-INDX.
                   15  W-PTDO-PROC-DHCPCS PIC X(05).
               10 W-PTDO-DARRAY-SIZE     PIC 9(03).
               10 W-PTDO-PROC-TOT-DCHRGS PIC 9(10)V99.
               10 W-PTDO-PROC-TOT-DUNITS PIC 9(05).
               10 W-PTDO-PROC-USED       PIC X(01).


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR THE PASS-THROUGH DEVICE     *
      *   ASSOCIATED HCPCS ARRAY FOR THE REVISED PASS-THROUGH       *
      *   DEVICE OFFSET LOGIC                                       *
      *   NEW FOR OCT 2010 - TABLE ADDED 08/06/2010                 *
      *                                                             *
      *   THIS TABLE HOLDS EVERY PT OFFSET DEVICE ASSOCIATED WITH   *
      *   A GIVEN PROCEDURE APC.  EACH RECORD HOLDS THE HCPCS AND   *
      *   AN INDICATOR TO INDICATE WHETHER THE HCPCS APPEARS ON     *
      *   THE CLAIM OR NOT.                                         *
      *                                                             *
      ***************************************************************
      ****** W-PTDO-ASSOC-HCPCS-INDX ************************

       01  W-PTDO-ASSOC-HCPCS-MAX        PIC S9(07)  COMP-3 VALUE +0.
       01  W-PTDO-ASSOC-HCPCS-TBL.
           05  W-PTDO-ASSOC-HCPCS-ENTRY OCCURS 0 TO 450 TIMES
                 DEPENDING ON W-PTDO-ASSOC-HCPCS-MAX
                 INDEXED BY W-PTDO-ASSOC-HCPCS-INDX.
               10 W-PTDO-ASSOC-HCPCS-HCPCS   PIC X(05).
               10 W-PTDO-ASSOC-HCPCS-IND     PIC X(01).

      ***************************************************************
      *    WORKING STORAGE SWITCH FOR WAGE INDEX RURAL FLOOR        *
      *    ADDED 10-28-2014                                         *
      ***************************************************************
       01  W-FLOOR-SWITCH  PIC X(01) VALUE 'Y'.
           88 W-FLOOR-LOOKUP VALUE 'Y'.
           88 W-WINX-LOOKUP  VALUE 'N'.

      ***************************************************************
      *    WORKING STORAGE VARIABLE TO HANDLE STATE CODES           *
      *    ADDED 11-06-2014                                         *
      ***************************************************************
       01   W-PSF-PROV-ST  PIC X(02) VALUE SPACES.



       LINKAGE SECTION.
      ***************************************************************   00000100
      *   WHEN FISS CALLS THIS PROGRAM, THEY GET THE LINKAGE        *   00000300
      *   SECTION.                                                  *   00000400
      ***************************************************************   00000600

      ***************************************************************
      * LAYUP TABLE AREA FOR OUTPATIENT PROVIDER SPECIFIC RECORD    *
      ***************************************************************

       01  L-PROV-SPEC-AREA.
               05  L-PSF-NPI                    PIC X(08).
               05  L-PSF-NPI-FILLER             PIC X(02).
               05  L-PSF-PROV-OSCAR.
                 10  L-PSF-PROV-ST              PIC X(02).
                 10  L-PSF-PROV-3456            PIC X(04).
               05  L-PSF-EFFDT                  PIC 9(08).
               05  L-PSF-FY-BEGIN-DT            PIC 9(08).
               05  L-PSF-REPORT-DT              PIC 9(08).
               05  L-PSF-TERMDT                 PIC 9(08).
               05  L-PSF-WAIVE-IND              PIC X(01).
               05  L-PSF-FI-NUM                 PIC 9(05).
               05  L-PSF-PROV-TYPE              PIC X(02).
               05  L-PSF-SPCL-LOCATION-IND      PIC X(01).
               05  L-PSF-WGIDX-RECLASS          PIC X(01).
               05  L-PSF-GEO-MSA                PIC X(04).
               05  L-PSF-WI-MSA                 PIC X(04).
               05  L-PSF-COLA                   PIC 9V9(03).
               05  L-PSF-STATE-CODE             PIC 9(02).
               05  L-PSF-TOPS-INDICATOR         PIC X(01).
               05  L-PSF-HOSP-QUAL-IND          PIC X(01).
               05  FILLER                       PIC X(01).
               05  L-PSF-OPCOST-RATIO           PIC 9V9(03).
               05  L-PSF-GEO-CBSA               PIC X(05).
               05  L-PSF-WI-CBSA                PIC X(05).
               05  L-PSF-SPEC-WGIDX             PIC 9(02)V9(04).
               05  L-PSF-SPEC-PYMT-IND          PIC X(01).
               05  L-PSF-APC-LINE-CNT           PIC 9(04).
               05  L-PSF-ESRD-CHILD-QUAL-IND    PIC X(01).
               05  L-PSF-DEVICE-CCR             PIC 9V9(03).
               05  L-PSF-CARRIER-LOCAL          PIC X(7).
               05  L-PSF-COUNTY-CODE            PIC 9(5).
               05  L-PSF-PYMT-CBSA              PIC X(5).
               05  L-PSF-PYMT-MODEL-ADJ         PIC 9V9(05).
               05  L-PSF-MPA                    PIC X(05).
               05  L-PSF-SUPPL-WI-IND           PIC X(01).
               05  L-PSF-SUPPL-WI               PIC 9(02)V9(04).
               05  FILLER                       PIC X(22).
               05  L-PSF-APC-TABLE     OCCURS 999 TIMES
                        DEPENDING ON L-PSF-APC-LINE-CNT.
                   10  L-PSF-APC                PIC X(04).
                   10  L-PSF-RED-COIN           PIC 9(04)V99.


      ***************************************************************   00000100
      *  INPUT RECORD FROM THE OCE/STANDARD SYSTEM                  *
      *-------------------------------------------------------------*
      * BELOW ARE THE VARIABLES THAT WILL BE PASSED                 *
      * TO PRICER FROM THE OCE BEGINNING OCT. 1, 2005 THERE WILL BE *
      *    - INCREASED SIZE OF SERVICE AND PAYMENT - 1 TO 2 BYTES   *
      *    - INCREASED SIZE OF PYMT ADJUSTMENT FLAG - 1 TO 2 BYTES  *
      *    CY 2009 EDITS - MADE 11/10/2008:                         *
      *    - INCREASED SIZE OF SERVICE UNITS - 7 TO 9 BYTES         *
      *    - ADDED COMPOSITE ADJUSTMENT FLAG - 2 BYTES              *
      *    CY 2021 EDITS - MADE 03/25/2021:                         *
      *    - ADDED PAYMENT ADJUSTMENT FLAG 2 - 2 BYTES              *
      ***************************************************************
       01  OPPS-LINE-CNT                  PIC 9(08) COMP.
       01  OCE-DATA.
           05  OPPS-OCE-LINE OCCURS 450 TIMES
                     DEPENDING ON OPPS-LINE-CNT.
               10  OPPS-HCPCS.
                 15  OPPS-ALPHA           PIC X(01).
                 15  FILLER               PIC X(04).
               10  OPPS-GRP.
                 15  FILLER               PIC X(01).
                 15  OPPS-APC             PIC X(04).
               10  OPPS-HCPCS-APC         PIC X(05).
               10  OPPS-SRVC-IND          PIC X(02).
               10  OPPS-PYMT-IND          PIC X(02).
               10  OPPS-DISC-FACT         PIC 9(01).
               10  OPPS-LITEM-DR-FLAG     PIC X(01).
               10  OPPS-PKG-FLAG          PIC X(01).
               10  OPPS-PYMT-ADJ-FLAG     PIC X(02).
               10  OPPS-SITE-SRVC-FLAG    PIC X(01).
               10  OPPS-SRVC-UNITS        PIC 9(09).
               10  OPPS-SUB-CHRG          PIC 9(08)V99.
               10  OPPS-LITEM-ACT-FLAG    PIC X(01).
               10  OPPS-COMP-ADJ-FLAG     PIC X(02).
               10  OPPS-PYMT-ADJ-FLAG2    PIC X(02).
       01  L-SERVICE-FROM-DATE       PIC 9(08).
       01  BENE-DEDUCT               PIC 9(03)V9(02).
       01  BENE-BLOOD-PINTS          PIC 9(01).


      ***************************************************************
      *   BELOW ARE THE VARIABLES THAT WILL BE PASSED BACK          *
      *   TO SS ASSOCIATED WITH THE BILL BEING PROCESSED            *
      *   - EFF. 04/01/2002 CALCULATE LINE ITEM OUTIER PAYMENT      *
      ***************************************************************
       01  A-ADDITIONAL-VARIABLES.
           05  A-CALC-VERS             PIC X(07).
           05  A-TOTAL-CLM-DEDUCT      PIC 9(03)V9(02).
           05  A-OUTLIER-PYMT          PIC 9(07)V9(02).
           05  A-TOT-CLM-PYMT          PIC 9(07)V9(02).
           05  A-TOT-CLM-CHRG          PIC 9(07)V9(02).
           05  A-CLM-RTN-CODE          PIC 9(02).
           05  A-MSA                   PIC X(04).
           05  A-CBSA                  PIC X(05).
           05  A-WINX                  PIC S9V9(04).
           05  A-BLOOD-PINTS-USED      PIC 9(01).
           05  A-BLOOD-DEDUCT-DUE      PIC 9(05)V9(02).
           05  A-DEVICE-CREDIT-QD      PIC 9(07)V9(02).
           05  A-LINE-ITEMS OCCURS 450 TIMES
                   DEPENDING ON OPPS-LINE-CNT.
             10  A-LITEM-PYMT          PIC 9(07)V9(02).
             10  A-LITEM-REIM          PIC 9(07)V9(02).
             10  A-TOTAL-LN-DEDUCT     PIC 9(03)V9(02).
             10  A-ADJ-COIN            PIC 9(05)V9(02).
             10  A-RED-COIN            PIC 9(05)V9(02).
             10  A-BLOOD-LN-DEDUCT     PIC 9(05)V9(02).
             10  A-RETURN-CODE         PIC 9(02).



      ***************************************************************
      *   BELOW ARE THE CLAIM SERVICE LINES (INPUT FROM FISS)       *
      ***************************************************************
       01  OCE-IN-DATE.
           05  OCE-IN-LINES OCCURS 450 TIMES.
              10  FILLER               PIC X(15).
              10  OPPS-LITEM-DOS       PIC 9(08).
              10  OPPS-LITEM-RVCD      PIC X(04).
              10  FILLER               PIC X(19).


      ***************************************************************
      *    CY 2012 EDIT - MADE 02/07/2012:                          *
      *    - ADDED TYPE OF BILL - 3 BYTES                           *
      ***************************************************************
       01  L-TYPE-OF-BILL            PIC X(03).
           88 BILL-TYPE-14X          VALUE '14A' THRU '149'.


      ***************************************************************
      *    CY 2014 EDIT - EFFECTIVE 01/01/2014:                     *
      *    - ADDED DEVICE CREDIT - 9 BYTES  (VALUE CODE FD)         *
      ***************************************************************
       01  L-DEVICE-CREDIT      PIC 9(07)V9(02).


      ***************************************************************
      *    CY 2016 EDIT - EFFECTIVE 01/01/2016:                     *
      *    - ADDED 10 VALUE CODES - QN-QW - 9 BYTES EACH            *
      ***************************************************************
       01  L-PAYER-ONLY-VALUE-CODES.
      *-------------------------------------------------------------*
      *    QN, QO & QP - FOR PASS-THROUGH DEVICE OFFSET             *
      *-------------------------------------------------------------*
           05  L-PAYER-ONLY-VC-QN   PIC 9(07)V9(02).
           05  L-PAYER-ONLY-VC-QO   PIC 9(07)V9(02).
           05  L-PAYER-ONLY-VC-QP   PIC 9(07)V9(02).
      *-------------------------------------------------------------*
      *    QQ - FOR TERMINATED PROCEDURE WITH PASS-THROUGH DEVICE   *
      *-------------------------------------------------------------*
           05  L-PAYER-ONLY-VC-QQ   PIC 9(07)V9(02).
      *-------------------------------------------------------------*
      *    QR, QS & QT - FOR PT DRUG/BIOLOGICAL OFFSETS             *
      *-------------------------------------------------------------*
           05  L-PAYER-ONLY-VC-QR   PIC 9(07)V9(02).
           05  L-PAYER-ONLY-VC-QS   PIC 9(07)V9(02).
           05  L-PAYER-ONLY-VC-QT   PIC 9(07)V9(02).
      *-------------------------------------------------------------*
      *    QU - FOR DEVICE CREDIT CAP AMOUNT                        *
      *-------------------------------------------------------------*
           05  L-PAYER-ONLY-VC-QU   PIC 9(07)V9(02).
      *-------------------------------------------------------------*
      *    QV & QW - FOR FUTURE USE                                 *
      *-------------------------------------------------------------*
           05  L-PAYER-ONLY-VC-QV   PIC 9(07)V9(02).
           05  L-PAYER-ONLY-VC-QW   PIC 9(07)V9(02).
      ***************************************************************
      *    CY 2017 EDIT - EFFECTIVE 01/01/2017:                     *
      *    - ADDED 2 NEW PRIOR TOTALS                               *
      ***************************************************************
       01  L-PRIOR-OUTL-TOTAL       PIC 9(10)V9(02).
       01  L-PRIOR-PYMT-TOTAL       PIC 9(10)V9(02).



      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **                 PROCEDURE DIVISION START                     **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************

       PROCEDURE DIVISION  USING OPPS-LINE-CNT
                                 OCE-DATA
                                 A-ADDITIONAL-VARIABLES
                                 L-PROV-SPEC-AREA
                                 L-SERVICE-FROM-DATE
                                 BENE-DEDUCT
                                 BENE-BLOOD-PINTS
                                 OCE-IN-DATE
                                 L-TYPE-OF-BILL
                                 L-DEVICE-CREDIT
                                 L-PAYER-ONLY-VALUE-CODES
                                 L-PRIOR-OUTL-TOTAL
                                 L-PRIOR-PYMT-TOTAL.


       0000-DATE-CONTROL.

      ************************************************************      00000100
      *                                                          *      00000200
      *    THIS SEPERATES EACH NEW YEAR INTO ITS OWN 1000-LEVEL  *      00000300
      *    PROCESS AREA.                                         *      00000400
      *                                                          *      00000500
      *    THIS VERSION PROCESSES CLAIMS SERVICED FROM           *      00000500
      *    CYS 2014 - 2021.                                      *      00000500
      *                                                          *      00000500
      ************************************************************      00000600
              IF L-SERVICE-FROM-DATE > 20201231
                 PERFORM 20000-PROCESS-MAIN-NEW
                    THRU 20000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20191231
                 PERFORM 19000-PROCESS-MAIN-NEW
                    THRU 19000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20181231
                 PERFORM 18000-PROCESS-MAIN-NEW
                    THRU 18000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20171231
                 PERFORM 17000-PROCESS-MAIN-NEW
                    THRU 17000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20161231
                 PERFORM 16000-PROCESS-MAIN-NEW
                    THRU 16000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20151231
                 PERFORM 15000-PROCESS-MAIN-NEW
                    THRU 15000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20141231
                 PERFORM 14000-PROCESS-MAIN-NEW
                    THRU 14000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20131231
                 PERFORM 13000-PROCESS-MAIN-NEW
                    THRU 13000-PROCESS-MAIN-NEW-EXIT
              ELSE
                 MOVE 53 TO A-CLM-RTN-CODE.
              GOBACK.




      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 13000 FOR CALENDAR YEAR 2014 PROCESSING        **
      **          SERVICE FROM DATES: 1/1/2014 - 12/31/2014           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE OCE)       *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ACCUMULATE PACKAGED MENTAL HEALTH CHARGES                  *
      *  7. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  8. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  9. CALCULATE SERVICE LINE PAYMENTS                            *
      * 10. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 11. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 12. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 13. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 14. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, COMPOSITE,    *
      *     AND MENTAL HEALTH CHARGES OF APPLICABLE PROCEDURES.  ALSO, *
      *     ADJUST LINE CHARGES AND PAYMENTS FOR PASS-THROUGH DEVICES  *
      *     FOR ELIGIBLE PROCEDURES.  ALL ADJUSTMENTS ARE DONE FOR     *
      *     OUTLIER DETERMINATION ONLY.                                *
      * 15. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 16. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR DRUG LINES;  *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE DRUG LINE'S REIMBURSEMENT                     *
      * 17. ACCUMULATE CLAIM TOTALS                                    *
      * 18. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       13000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY)   *
      *                                                               *
      *****************************************************************
              PERFORM 13100-INIT
                 THRU 13100-INIT-EXIT.

      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - PHP-APC-FLAG - PARTIAL HOSPITALIZATION CLAIM              *
      *     (APCS 00172, 00173, 00175, & 00176)                       *
      *   - APC34-FLAG - MENTAL HEALTH CLAIM                          *
      *   - PTD-FLAG - PASS-THROUGH DEVICE(S) ON CLAIM FOR OUTLIER    *
      *   - PTRADIO-CLAIM-FLAG - PASS-THROUGH RADIOPAHARM(S) ON CLAIM *
      *   - PTCA-CLAIM-FLAG - PASS-THROUGH CONTRAST AGENT ON CLAIM    *
      *     CREATE PASS-THROUGH CONTRAST AGENT DAY TABLE              *
      *   - PTDO-CLAIM-FLAG - PASS-THROUGH DEVICE ON CLAIM FOR OFFSET *
      *     CREATE PASS-THROUGH DEVICE HCPCS TABLE                    *
      *   - DEVCR-CLAIM-FLAG - DEVICE CREDIT AND LINE(S) ELIGIBLE TO  *
      *     RECEIVE DEVICE CREDIT ON CLAIM                            *
      *                                                               *
      *   - DISABLED CY 2009: C1820-OFFSET-FLAG - DEVICE OFFSET CLAIM *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY PASS-THROUGH CONTRAST AGENT DAY TABLE FOR CLAIM  *
      *--------------------------------------------------------*
              MOVE 0 TO W-PTCA-DAY-MAX.

      *--------------------------------------------------------*
      * EMPTY PASS-THROUGH DEVICE HCPCS TABLE FOR CLAIM        *
      *--------------------------------------------------------*
              MOVE 0 TO W-PTDO-HCPCS-MAX.

              PERFORM 13125-INIT
                 THRU 13125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.


      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CALCULATE TOTAL PACKAGED MENTAL HEALTH CHARGES,    *
      *            CREATE PASS-THROUGH DEVICE TABLE (OUTLIER), CREATE *
      *            NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH        *
      *            RADIOPHARMACEUTICAL OFFSET, CREATE CONTRAST        *
      *            AGENT PROCEDURE TABLE FOR PASS-THROUGH CONTRAST    *
      *            AGENT OFFSET & CREATE PASS-THROUGH DEVICE OFFSET   *
      *            PROCEDURE TABLE FOR PASS-THROUGH DEVICE OFFSET.    *
      *            (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY TABLES FOR NEW CLAIM                             *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX W-BLD-MAX W-CMP-MAX W-PTD-MAX
                        W-NUCMED-MAX W-CAPROC-MAX W-PTDO-PROC-MAX.

              PERFORM 13150-INIT
                 THRU 13150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      *--------------------------------------------------------*
      * CALCULATE TOTAL OFFSET AMT FOR PT RADIOPHARM LINE(S)   *
      * (# OF UNITS SUMMED LIMITED TO THE LESSER OF THE # OF   *
      *  PT RADIOPHARM HCPCS & THE # OF NUCLEAR MEDICINE UNITS)*
      *--------------------------------------------------------*
              IF W-NUCMED-MAX > 0
                 SET W-NUCMED-INDX TO 1
                 PERFORM UNTIL (W-NUCMED-INDX > W-NUCMED-MAX) OR
                               (W-NUCMED-INDX > H-PTRADIO-HCPCS-CNT)
                    COMPUTE H-NUCMED-TOT-OFFSET ROUNDED =
                            H-NUCMED-TOT-OFFSET +
                            W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX)
                    SET W-NUCMED-INDX UP BY 1
                 END-PERFORM
              END-IF.

      *--------------------------------------------------------*
      * CALCULATE TOTAL OFFSET AMT PER DAY FOR PT CONTRAST     *
      * AGENT LINE(S) (# OF UNITS SUMMED LIMITED TO THE LESSER *
      * OF THE # OF PT CONTRAST AGENT HCPCS & THE # OF PT      *
      * CONTRAST AGENT PROCEDURE APC UNITS PER DAY)            *
      *--------------------------------------------------------*
              IF W-PTCA-DAY-MAX > 0 AND W-CAPROC-MAX > 0
                 SET W-PTCA-DAY-INDX TO 1
                 PERFORM UNTIL (W-PTCA-DAY-INDX > W-PTCA-DAY-MAX)
                    PERFORM 13396-TOTAL-DAY-PTCA-OFFS
                       THRU 13396-TOTAL-DAY-PTCA-OFFS-EXIT
                    SET W-PTCA-DAY-INDX UP BY 1
                 END-PERFORM
              END-IF.

      *--------------------------------------------------------*
      * MAP PASS-THROUGH DEVICE HCPCS TO THEIR CORRESPONDING   *
      * OFFSET PROCEDURES                                      *
      *--------------------------------------------------------*
              PERFORM 13397-PTDO-MAPPINGS-1
                 THRU 13397-PTDO-MAPPINGS-1-EXIT
                 VARYING W-PTDO-HCPCS-INDX FROM 1 BY 1
                 UNTIL W-PTDO-HCPCS-INDX > W-PTDO-HCPCS-MAX.

              PERFORM 13397-PTDO-MAPPINGS-2
                 THRU 13397-PTDO-MAPPINGS-2-EXIT
                 VARYING W-PTDO-HCPCS-INDX FROM 1 BY 1
                 UNTIL W-PTDO-HCPCS-INDX > W-PTDO-HCPCS-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 4 - INITIALIZE W-DCP-MAX                               *
      *   ------                                                      *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.

      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, POPULATE PASS-THROUGH      *
      *            DEVICE TABLE WITH ELIGIBLE PROCEDURE DATA AND      *
      *            DEVICE LINE ITEM PAYMENT, AND MOVE LINE ITEM       *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 13400-CALCULATE
                 THRU 13400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, COMPOSITES, MENTAL HEALTH, AND *
      *            PASS-THROUGH DEVICES, AND CALCULATE OUTLIER        *
      *            PAYMENTS                                           *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 13600-ADJ-CHRG-OUTL
                 THRU 13600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


      *****************************************************************
      *                                                               *
      *   STEP 7 - CALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS  *
      *   ------   FOR STATUS INDICATOR G & K LINES.  THE DAILY INPA- *
      *            TIENT COINSURANCE LIMIT IS APPLIED USING THE WAGE  *
      *            ADJUSTED COINSURANCE OF EACH DAY'S MOST EXPENSIVE  *
      *            PROCEDURE OR VISIT.                                *
      *            (LOOP THROUGH THE DRUG COINSURANCE TABLE)          *
      *                                                               *
      *****************************************************************
                IF GJK-FLAG = 'Y'
                   PERFORM 13800-ADJ-STV-REIM
                      THRU 13800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                ELSE
                   NEXT SENTENCE.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 13900-END-PRICE-RTN
                 THRU 13900-END-PRICE-RTN-EXIT.

       13000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY COINSURANCE LIMIT (H-IP-LIMIT)         *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       13100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE VARIABLES                         *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 11/03/2008 - APC33-FLAG REPLACED BY PHP-APC-FLAG            *
      * 11/12/2008 - BRACHY-APC-FLAG REMOVED, NOT USED FOR CY 2009  *
      * 02/09/2009 - PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG ADDED    *
      * 11/16/2009 - RADIOPH-APC-FLAG REMOVED; PTCA-CLAIM-FLAG,     *
      *              PTCA-LINE FLAG ADDED                           *
      * 02/07/2012 - BILL14X-FLAG REMOVED                           *
      * 11/18/2013 - DEVCR-CLAIM-FLAG ADDED                         *
      *-------------------------------------------------------------*
             MOVE 'N' TO PHP-APC-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG       C1820-OFFSET-FLAG
                         PHP-HCPCS-FLAG      MH-HCPCS-FLAG
                         APC34-FLAG
                         PTD-FLAG            PTD-LINE-FLAG
                         PTD-PROC-FLAG       BLD-DEDUC-HCPCS-FLAG
                         PTRADIO-CLAIM-FLAG  PTRADIO-LINE-FLAG
                         PTCA-CLAIM-FLAG     PTCA-LINE-FLAG
                         DEVCR-CLAIM-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-DEDUCT-DUE
                          A-BLOOD-PINTS-USED
                          A-WINX
                          W-LNC-MAX
                          A-DEVICE-CREDIT-QD.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.

      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 13100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 13100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 13100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION13 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = '1' OR '2'
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX
                      MOVE 1216 TO H-IP-LIMIT
                      GO TO 13100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 13100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 13100-INIT-EXIT.

             MOVE 1216 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      * APPLY WAGE INDEX FLOOR POLICY                               *
      * UPDATE WITH NEW FLOOR PARAGRAPH EVERY JANUARY               *
      *-------------------------------------------------------------*
             PERFORM 13120-FLOOR-2014
                THRU 13120-FLOOR-2014-EXIT.

      *-------------------------------------------------------------*
      *   GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN  *
      *   BY THE PSF SPECIAL WAGE INDEX VALUE)                      *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             IF H-WINX = 0
                PERFORM 13200-CALC-WAGEINDX
                   THRU 13200-CALC-WAGEINDX-EXIT.

       13100-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  NEW CY 2014 FLOOR FOR CBSA WAGE INDEX                      *
      *  IPPS PRICER PGM FLOORS TAKEN FROM: PPDRV143                *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  SYNC ALL OF THE FOLLOWING WITH INPATIENT.                  *
      *  SEE IPPS PRICER MAINTAINER.                                *
      *                                                             *
      * * SPECIAL NOTES *                                           *
      *   -------------                                             *
      *   1) CHANGE "'N'" (INPATIENT)                               *
      *          TO "' '" (OUTPATIENT)                              *
      *                                                             *
      *   2) CHANGE 'P-NEW-CBSA-SPEC-PAY-IND' (INPATIENT)           *
      *          TO 'L-PSF-SPEC-PYMT-IND'     (OUTPATIENT)          *
      *                                                             *
      *   3) CHANGE 'HOLD-PROV-CBSA' (INPATIENT)                    *
      *          TO 'H-PSF-CBSA'     (OUTPATIENT)                   *
      *                                                             *
      *   4) CHANGE 'P-NEW-STATE'   (INPATIENT)                     *
      *          TO 'L-PSF-PROV-ST' (OUTPATIENT)                    *
      *                                                             *
      *   5) ADD SINGLE QUOTES AROUND L-PSF-PROV-ST VALUES          *
      *                                                             *
      *   BE SURE TO MAKE THESE FIVE CHANGES EVERY JANUARY          *
      *                                                             *
      ***************************************************************
       13120-FLOOR-2014.

429200        IF H-PSF-CBSA = '   07'
429300           AND L-PSF-SPEC-PYMT-IND      = 'Y'
429400           AND L-PSF-PROV-ST = '07'
429500               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
429600               MOVE '   07' TO H-PSF-CBSA.
429700
429800        IF H-PSF-CBSA = '   36'
429900           AND L-PSF-SPEC-PYMT-IND      = 'Y'
430000           AND L-PSF-PROV-ST = '36'
430100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
430200               MOVE '   36' TO H-PSF-CBSA.
430300
430400        IF H-PSF-CBSA = '10900'
430500           AND L-PSF-PROV-ST = '31'
430600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
430700               MOVE '   31' TO H-PSF-CBSA.
430800
430900        IF H-PSF-CBSA = '14484'
431000           AND L-PSF-SPEC-PYMT-IND      = 'Y'
431100           AND L-PSF-PROV-ST = '22'
431200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
431300               MOVE '   22' TO H-PSF-CBSA.
431400
431500        IF H-PSF-CBSA = '17300'
431600           AND L-PSF-PROV-ST = '18'
431700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
431800               MOVE '   18' TO H-PSF-CBSA.
431900
432000        IF H-PSF-CBSA = '22900'
432100           AND L-PSF-PROV-ST = '37'
432200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
432300               MOVE '   37' TO H-PSF-CBSA.
432400
432500        IF H-PSF-CBSA = '25540'
432600          AND L-PSF-SPEC-PYMT-IND      = 'Y'
432700           AND L-PSF-PROV-ST = '07'
432800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
432900               MOVE '   07' TO H-PSF-CBSA.
433000
433100        IF H-PSF-CBSA = '25540'
433200          AND L-PSF-SPEC-PYMT-IND      = 'Y'
433300           AND L-PSF-PROV-ST = '22'
433400               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
433500               MOVE '   22' TO H-PSF-CBSA.
433600
433700        IF H-PSF-CBSA = '26820'
433800           AND L-PSF-SPEC-PYMT-IND      = 'Y'
433900           AND L-PSF-PROV-ST = '53'
434000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
434100               MOVE '   53' TO H-PSF-CBSA.
434200
434300        IF H-PSF-CBSA = '27180'
434400           AND L-PSF-SPEC-PYMT-IND      = 'Y'
434500           AND L-PSF-PROV-ST = '25'
434600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
434700               MOVE '   25' TO H-PSF-CBSA.
434800
434900        IF H-PSF-CBSA = '28700'
435000           AND L-PSF-PROV-ST = '44'
435100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
435200               MOVE '   44' TO H-PSF-CBSA.
435300
435400        IF H-PSF-CBSA = '28700'
435500           AND L-PSF-PROV-ST = '49'
435600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
435700               MOVE '   49' TO H-PSF-CBSA.
435800
435900        IF H-PSF-CBSA = '35644'
436000           AND L-PSF-SPEC-PYMT-IND      = 'Y'
436100           AND L-PSF-PROV-ST = '07'
436200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
436300               MOVE '   07' TO H-PSF-CBSA.
436400
436500        IF H-PSF-CBSA = '37620'
436600           AND L-PSF-PROV-ST = '36'
436700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
436800               MOVE '   36' TO H-PSF-CBSA.
436900
437000        IF H-PSF-CBSA = '43580'
437100           AND L-PSF-PROV-ST = '43'
437200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
437300               MOVE '   43' TO H-PSF-CBSA.
437400
437500        IF H-PSF-CBSA = '48540'
437600           AND L-PSF-PROV-ST = '36'
437700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
437800               MOVE '   36' TO H-PSF-CBSA.
437900
438000        IF H-PSF-CBSA = '48540'
438100           AND L-PSF-PROV-ST = '51'
438200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
438300               MOVE '   51' TO H-PSF-CBSA.
438400
438500        IF H-PSF-CBSA = '48864'
438600           AND L-PSF-PROV-ST = '31'
438700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
438800               MOVE '   31' TO H-PSF-CBSA.
438900
439000        IF H-PSF-CBSA = '49660'
439100           AND L-PSF-PROV-ST = '36'
439200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
439300               MOVE '   36' TO H-PSF-CBSA.
439400
439500        IF H-PSF-CBSA = '49660'
439600           AND L-PSF-PROV-ST = '39'
439700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
439800               MOVE '   39' TO H-PSF-CBSA.
439900
440000        IF H-PSF-CBSA = '19060'
440100           AND L-PSF-PROV-ST = '21'
440200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
440300               MOVE '   21' TO H-PSF-CBSA.
440400
440500        IF H-PSF-CBSA = '22020'
440600           AND L-PSF-PROV-ST = '24'
440700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
440800               MOVE '   24' TO H-PSF-CBSA.
440900
441000        IF H-PSF-CBSA = '22020'
441100           AND L-PSF-PROV-ST = '35'
441200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
441300               MOVE '   35' TO H-PSF-CBSA.
441400
441500        IF H-PSF-CBSA = '24220'
441600           AND L-PSF-PROV-ST = '24'
441700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
441800               MOVE '   24' TO H-PSF-CBSA.
441900
442000        IF H-PSF-CBSA = '24220'
442100           AND L-PSF-PROV-ST = '35'
442200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
442300               MOVE '   35' TO H-PSF-CBSA.
442400
442500        IF H-PSF-CBSA = '30300'
442600           AND L-PSF-PROV-ST = '50'
442700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
442800               MOVE '   50' TO H-PSF-CBSA.
442900
443000        IF H-PSF-CBSA = '39300'
443100           AND L-PSF-PROV-ST = '22'
443200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
443300               MOVE '   22' TO H-PSF-CBSA.
443400
443500        IF H-PSF-CBSA = '39300'
443600           AND L-PSF-PROV-ST = '41'
443700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
443800               MOVE '   41' TO H-PSF-CBSA.
443900
444000        IF H-PSF-CBSA = '44600'
444100           AND L-PSF-PROV-ST = '36'
444200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
444300               MOVE '   36' TO H-PSF-CBSA.
444400
444500        IF H-PSF-CBSA = '45500'
444600           AND L-PSF-PROV-ST = '45'
444700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
444800               MOVE '   45' TO H-PSF-CBSA.


       13120-FLOOR-2014-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND AN APC / HCPCS      *
      *                                                             *
      *  - SET FLAG IF APC = 0172/0173/0175/0176 (PARTIAL HOSP.)    *
      *  - SET FLAG IF APC = 0034 (FOR MENTAL HEALTH CHARGES)       *
      *    (NEW FOR CY 2008 - ADDED 11/28/2007)                     *
      *  - SET FLAG IF PASS-THROUGH DEVICE(S) ON CLAIM: FOR OUTLIER *
      *    (NEW FOR CY 2008 - ADDED 02/11/2008)                     *
      *  - SET FLAG IF PASS-THROUGH RADIOPHARMS(S) ON CLAIM         *
      *    (NEW FOR APRIL CY 2009 - ADDED 02/10/2009)               *
      *  - SET FLAG IF PASS-THROUGH CONTRAST AGENT(S) ON CLAIM      *
      *    (NEW FOR JANUARY CY 2010 - ADDED 11/15/2009)             *
      *  - SET FLAG IF PASS-THROUGH DEVICE(S) ON CLAIM: FOR OFFSET  *
      *    (NEW FOR OCTOBER CY 2010 - ADDED 08/02/2010)             *
      *  - SET FLAG IF CLAIM IS ELIGIBLE FOR DEVICE CREDIT          *
      *    (NEW FOR JANUARY CY 2014)                                *
      *                                                             *
      *  - DISABLED: SET FLAG IF HCPCS = C1820 (FOR DEVICE OFFSETS) *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION HCPCS FROM     *
      *              0033 TO 0172 & 0173 FOR CY 2009                *
      *                                                             *
      * 11/12/2008 - HCPCS C1820 EXPIRED FROM PASS-THROUGH STATUS   *
      *              DECEMBER 2007, OFFSET FLAG LOGIC DISABLED      *
      *                                                             *
      * 08/02/2010 - ADDED LOGIC TO SET PASS-THOUGH DEVICE FLAG FOR *
      *              DEVICE OFFSETS AND POPULATE THE CORRESPONDING  *
      *              TABLE                                          *
      *                                                             *
      * 11/15/2010 - ADDED APCS 0175 & 0176 TO LIST OF PHP APCS     *
      *                                                             *
      * 11/18/2013 - ADDED LOGIC TO SET DEVICE CREDIT CLAIM FLAG    *
      *                                                             *
      ***************************************************************
       13125-INIT.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A PHP APC (PARTIAL HOSP)*
      *-------------------------------------------------------------*
             IF OPPS-APC (LN-SUB) = '0172' OR
                OPPS-APC (LN-SUB) = '0173' OR
                OPPS-APC (LN-SUB) = '0175' OR
                OPPS-APC (LN-SUB) = '0176'
                MOVE 'Y' TO PHP-APC-FLAG.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS APC 0034                *
      *-------------------------------------------------------------*
             IF OPPS-APC (LN-SUB) = '0034'
                MOVE 'Y' TO APC34-FLAG.

      *-------------------------------------------------------------*
      * FOR CY 2010, NO HCPCS HAVE PASS-THROUGH STATUS              *
      * ** FOR OLD PT DEVICE LOGIC, REPLACED BY NEW LOGIC           *
      *-------------------------------------------------------------*
      *      IF OPPS-HCPCS (LN-SUB) = 'C1820'
      *         MOVE 'Y' TO C1820-OFFSET-FLAG.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST ONE LINE IS A PASS-THROUGH DEVICE  *
      * (FOR OUTLIER PAYMENT CALCULATION)                           *
      *-------------------------------------------------------------*
             PERFORM 13665-SET-PTD-LINE-FLAG
                THRU 13665-SET-PTD-LINE-FLAG-EXIT.

             IF PTD-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTD-FLAG
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE IS PASS-THROUGH RADIOPHARM  *
      * AND ACCUMULATE TOTAL PT RADIOPHARM LINES & CHARGES          *
      *-------------------------------------------------------------*
             PERFORM 13680-SET-PTRADIO-LINE-FLAG
                THRU 13680-SET-PTRADIO-LINE-FL-EXIT.

             IF PTRADIO-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTRADIO-CLAIM-FLAG
                ADD 1 TO H-PTRADIO-HCPCS-CNT
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-PTRADIO-TOT-CHRGS ROUNDED =
                        H-PTRADIO-TOT-CHRGS + H-SUB-CHRG
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE IS A PASS-THROUGH CONTRAST  *
      * AGENT AND ACCUMULATE TOTAL PT CONTRAST AGENT LINES &        *
      * CHARGES, SUM BY LINE ITEM DATE OF SERVICE, & CREATE A       *
      * RECORD FOR EACH DAY IN THE PASS-THROUGH CONTRAST AGENT      *
      * DAY TABLE                                                   *
      *-------------------------------------------------------------*
             PERFORM 13681-SET-PTCA-LINE-FLAG
                THRU 13681-SET-PTCA-LINE-FL-EXIT.

             IF PTCA-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTCA-CLAIM-FLAG
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                PERFORM 13130-LOAD-PTCA-DAY-TABLE
                   THRU 13130-LOAD-PTCA-DAY-TABLE-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE IS A PASS-THROUGH DEVICE    *
      * ON THE CLAIM AND CREATE A RECORD FOR THE PT DEVICE HCPCS    *
      * LINE IN THE PT DEVICE HCPCS TABLE                           *
      *-------------------------------------------------------------*
             PERFORM 13682-SET-PTDO-LINE-FLAG
                THRU 13682-SET-PTDO-LINE-FL-EXIT.

             IF PTDO-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTDO-CLAIM-FLAG
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS
                PERFORM 13132-LOAD-PTDO-HCPCS-TBL
                   THRU 13132-LOAD-PTDO-HCPCS-TBL-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A DEVICE CREDIT SHOULD BE APPLIED           *
      *-------------------------------------------------------------*
             IF L-DEVICE-CREDIT > 0
                SEARCH ALL DEV-CR14
                    AT END
                       CONTINUE
                    WHEN DEV-APC14 (DEV-INDX14) = OPPS-APC (LN-SUB)
                       MOVE 'Y' TO DEVCR-CLAIM-FLAG
             END-IF.


       13125-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE PASS-THROUGH CONTRAST AGENT HCPCS COUNT AND     *
      *  CHARGES FOR EACH DAY WITH A PASS-THROUGH CONTRAST AGENT    *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY LINE ITEM DATE OF SERVICE (LIDOS) - *
      *    EARLIEST TO LATEST DATE                                  *
      *                                                             *
      *  EACH PT CONTRAST AGENT HCPCS LINE'S CHARGES ARE ADDED TO   *
      *  THE TOTAL FOR ITS LIDOS.  THESE CHARGES ARE LATER USED     *
      *  TO DETERMINE THE PROPORTION OF THE DAY'S TOTAL CONTRAST    *
      *  PROCEDURE OFFSET THAT SHOULD BE SUBTRACTED FROM A GIVEN PT *
      *  CONTRAST AGENT HCPCS'S LINE PAYMENT.                       *
      *                                                             *
      *  11/16/2009 - LOGIC ADDED FOR CY 2010                       *
      *                                                             *
      ***************************************************************
       13130-LOAD-PTCA-DAY-TABLE.

      *-------------------------------------------------------------*
      * GET THE LINE'S SERVICE DATE & CHARGES FOR TABLE SEARCH      *
      *-------------------------------------------------------------*
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-PTCA-LIDOS.
             MOVE OPPS-SUB-CHRG (LN-SUB)  TO H-SUB-CHRG.

      *-------------------------------------------------------------*
      * ADD OR UPDATE CONTRAST AGENT DAY ENTRY FOR THE LIDOS        *
      *-------------------------------------------------------------*
                PERFORM 13130-SEARCH-PTCA-LIDOS
                   THRU 13130-SEARCH-PTCA-LIDOS-EXIT.

       13130-LOAD-PTCA-DAY-TABLE-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW PT CONTRAST AGENT DAY TABLE RECORD  *
      * SHOULD BE ADDED OR IF AN EXISITING RECORD MUST BE UPDATED   *
      *                                                             *
      ***************************************************************
       13130-SEARCH-PTCA-LIDOS.

      *-------------------------------------------------------------*
      * SEARCH PT CONTRAST AGENT DAY TABLE STARTING AT ENTRY #1     *
      *-------------------------------------------------------------*
             SET W-PTCA-DAY-INDX TO 1.
             SEARCH W-PTCA-DAY-ENTRY VARYING W-PTCA-DAY-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S LIDOS IS NOT ALREADY IN THE TABLE,    *
      * ADD IT                                                      *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 13130-ADD-ENTRY
                      THRU 13130-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S LIDOS IS ALREADY IN THE TABLE,        *
      * UPDATE THE ENTRY                                            *
      *-------------------------------------------------------------*
                WHEN W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX) = H-PTCA-LIDOS
                   PERFORM 13130-UPDATE-ENTRY
                      THRU 13130-UPDATE-ENTRY-EXIT.

       13130-SEARCH-PTCA-LIDOS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW PT CONTRAST AGENT DAY RECORD IN THE CORRECT  *
      * POSITION (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE *
      *                                                             *
      ***************************************************************
       13130-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTCA-DAY-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-PTCA-DAY-INDX TO W-PTCA-DAY-MAX.
             INITIALIZE W-PTCA-DAY-ENTRY (W-PTCA-DAY-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW PT CONTRAST AGENT DAY ENTRY FOR THE *
      * CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE TABLE       *
      * ACCORDING TO ITS LIDOS - EARLIEST TO LATEST LIDOS           *
      *-------------------------------------------------------------*
             PERFORM 13130-STAGE-PTCA-DAY-ENTRY
                THRU 13130-STAGE-PTCA-DAY-ENTRY-EXT
                  UNTIL W-PTCA-DAY-INDX = 1 OR
                     H-PTCA-LIDOS NOT <
                       W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-PTCA-LIDOS TO W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX).
             MOVE 1 TO W-PTCA-DAY-HCPCS-CNT (W-PTCA-DAY-INDX).
             MOVE H-SUB-CHRG TO W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX).

       13130-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING PT CONTRAST AGENT DAY RECORD WITH THE   *
      * SAME LIDOS AS THE CURRENT SERVICE LINE                      *
      *                                                             *
      ***************************************************************
       13130-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE LIDOS'S TOTAL SUBMITTED CHARGES & HCPCS COUNT*
      *-------------------------------------------------------------*
             ADD 1 TO W-PTCA-DAY-HCPCS-CNT (W-PTCA-DAY-INDX).
             ADD H-SUB-CHRG TO W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX).

       13130-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING PT CONTRAST AGENT DAY RECORD WITH A LATER *
      * LIDOS DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR *
      * THE NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.   *
      *                                                             *
      ***************************************************************
       13130-STAGE-PTCA-DAY-ENTRY.

             MOVE W-PTCA-DAY-ENTRY (W-PTCA-DAY-INDX - 1) TO
                  W-PTCA-DAY-ENTRY (W-PTCA-DAY-INDX).
             SET W-PTCA-DAY-INDX DOWN BY 1.

       13130-STAGE-PTCA-DAY-ENTRY-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE PASS-THROUGH DEVICE HCPCS TABLE WITH PASS-THROUGH *
      *  DEVICE LINE INFORMATION                                    *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY SUBMITTED CHARGE                    *
      *    HIGHEST TO LOWEST,                                       *
      *        THEN BY LINE UNITS                                   *
      *          HIGHEST TO LOWEST                                  *
      *                                                             *
      *  THESE RECORDS ARE LATER USED TO DETERMINE THE PASS-THROUGH *
      *  DEVICE OFFSET AMOUNT IF APPLICABLE.                        *
      *                                                             *
      *  08/02/2010 - LOGIC ADDED FOR OCT 2010                      *
      *                                                             *
      ***************************************************************
       13132-LOAD-PTDO-HCPCS-TBL.

      *-------------------------------------------------------------*
      * POPULATE VARIABLES FOR TABLE SORTING                        *
      *-------------------------------------------------------------*
             MOVE H-SUB-CHRG   TO H-PTDO-CHRG.
             MOVE H-SRVC-UNITS TO H-PTDO-UNITS.


      *-------------------------------------------------------------*
      * ADD THE CURRENT PASS-THROUGH DEVICE HCPCS LINE TO TABLE     *
      *-------------------------------------------------------------*
             PERFORM 13132-ADD-ENTRY
                THRU 13132-ADD-ENTRY-EXIT.

       13132-LOAD-PTDO-HCPCS-TBL-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW PT DEVICE HCPCS RECORD IN THE CORRECT        *
      * POSITION (HIGHEST TO LOWEST SUBMITTED CHARGE & THEN HIGHEST *
      * TO LOWEST LINE UNITS)                                       *
      *                                                             *
      ***************************************************************
       13132-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTDO-HCPCS-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-PTDO-HCPCS-INDX TO W-PTDO-HCPCS-MAX.
             INITIALIZE W-PTDO-HCPCS-ENTRY (W-PTDO-HCPCS-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW PT DEVICE HCPCS ENTRY FOR THE       *
      * CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE TABLE       *
      * ACCORDING TO ITS SUBMITTED CHARGES & LINE UNITS (BOTH       *
      * HIGHEST TO LOWEST)                                          *
      *-------------------------------------------------------------*
             PERFORM 13132-STAGE-PTDO-HCPCS-ENTRY
                THRU 13132-STAGE-PTDO-HCPCS-ENTRY-X
                  UNTIL W-PTDO-HCPCS-INDX = 1 OR
                     H-PTDO-CHRGUNIT NOT >
                       W-PTDO-HCPCS-CHRGUNIT (W-PTDO-HCPCS-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE OPPS-HCPCS (LN-SUB) TO
                  W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX).
             MOVE LN-SUB TO
                  W-PTDO-HCPCS-LNSUB (W-PTDO-HCPCS-INDX).
             MOVE H-PTDO-CHRG TO
                  W-PTDO-HCPCS-SUB-CHRG (W-PTDO-HCPCS-INDX).
             MOVE H-PTDO-UNITS TO
                  W-PTDO-HCPCS-UNITS (W-PTDO-HCPCS-INDX).
             MOVE 0 TO W-PTDO-HCPCS-PROC-CNT (W-PTDO-HCPCS-INDX).
             MOVE SPACES TO W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX).
             MOVE 0 TO W-PTDO-HCPCS-PROC-LNSUB (W-PTDO-HCPCS-INDX).


       13132-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING PT CONTRAST AGENT DAY RECORD WITH A LATER *
      * LIDOS DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR *
      * THE NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.   *
      *                                                             *
      ***************************************************************
       13132-STAGE-PTDO-HCPCS-ENTRY.

             MOVE W-PTDO-HCPCS-ENTRY (W-PTDO-HCPCS-INDX - 1) TO
                  W-PTDO-HCPCS-ENTRY (W-PTDO-HCPCS-INDX).
             SET W-PTDO-HCPCS-INDX DOWN BY 1.

       13132-STAGE-PTDO-HCPCS-ENTRY-X.
             EXIT.


      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES, *
      *  AND CALCULATE TOTAL PACKAGED MENTAL HEALTH CHARGES.        *
      *  CREATE PASS-THROUGH CONTRAST AGENT PROC TABLE (NEW CY2010) *
      *  CREATE PASS-THROUGH DEVICE PROC TABLE (NEW OCT 2010)       *
      *                                                             *
      *  ** UPDATE PARTIAL HOSPITALIZATION (PHP) & MENTAL HEALTH    *
      *     (MH) TABLE REFERENCES EVERY JANUARY                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (NOT A PARTIAL HOSPITALIZATION OR       *
      *                      MENTAL HEALTH HCPCS))                  *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (PARTIAL HOSP. APC IS NOT ON THE CLAIM   *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  PARTIAL HOSPITALIZATION HCPCS)      *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       13150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *  OVERRIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      ***************************************************************
             IF OPPS-APC (LN-SUB) = '0339'
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).


      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 13250-CALC-DISCOUNT
                THRU 13250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 13150-INIT-EXIT.

      ***************************************************************
      *  CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH         *
      *  RADIOPHARM OFFSET WHEN PASS-THROUGH RADIOPHARM(S) ON CLAIM *
      *  EFFECTIVE APRIL 2009                                       *
      ***************************************************************
             IF PTRADIO-CLAIM-FLAG = 'Y'
                PERFORM 13165-PROCESS-NUCLEAR-MED
                   THRU 13165-PROCESS-NUCLEAR-MED-EXIT.


      ***************************************************************
      *  CREATE CONTRAST AGENT PROCEDURE TABLE FOR PASS-THROUGH     *
      *  CONTRAST AGENT OFFSET WHEN PT CONTRAST AGENT(S) ON CLAIM   *
      *  EFFECTIVE JANUARY 2010                                     *
      ***************************************************************
             IF PTCA-CLAIM-FLAG = 'Y'
                PERFORM 13168-PROCESS-PTCA-PROC
                   THRU 13168-PROCESS-PTCA-PROC-EXIT.


      ***************************************************************
      *  CREATE PASS-THROUGH DEVICE PROCEDURE TABLE FOR PASS-       *
      *  THROUGH DEVICE OFFSET WHEN PT DEVICE(S) ON CLAIM           *
      *  EFFECTIVE OCTOBER 2010                                     *
      ***************************************************************
             IF PTDO-CLAIM-FLAG = 'Y'
                PERFORM 13169-PROCESS-PTDO-PROC
                   THRU 13169-PROCESS-PTDO-PROC-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      *-------------------------------------------------------------*
             MOVE 'N' TO PHP-HCPCS-FLAG  MH-HCPCS-FLAG.


      ***************************************************************
      *  SEARCH PARTIAL HOSPITALIZATION (PHP) TABLE FOR LINE HCPCS  *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      *  11/15/2010 - FOR CY 2011, USE CY 2010 TABLE                *
      *  11/09/2012 - FOR CY 2013, USE CY 2013 TABLE                *
      *  11/25/2013 - FOR CY 2014, USE CY 2014 TABLE                *
      ***************************************************************
             SEARCH ALL PHP-ENTRY14
                AT END
                   MOVE 'N' TO PHP-HCPCS-FLAG
                WHEN PHP-HCPCS14 (PHP-INDX14) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO PHP-HCPCS-FLAG.


      ***************************************************************
      *  SEARCH MENTAL HEALTH (MH) TABLE FOR LINE HCPCS             *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      *  11/15/2010 - FOR CY 2011, USE CY 2010 TABLE                *
      *  11/04/2011 - FOR CY 2012, USE CY 2012 TABLE                *
      *  11/09/2012 - FOR CY 2013, USE CY 2013 TABLE                *
      *  11/25/2013 - FOR CY 2014, USE CY 2014 TABLE                *
      ***************************************************************
             SEARCH ALL MH-ENTRY14
                AT END
                   MOVE 'N' TO MH-HCPCS-FLAG
                WHEN MH-HCPCS14 (MH-INDX14) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO MH-HCPCS-FLAG.


      ***************************************************************
      *   POPULATE PASS-THROUGH DEVICE TABLE W/ PASS-THROUGH        *
      *   DEVICE LINE DATA (FOR OUTLIER PAYMENT ADJUSTMENT)         *
      *-------------------------------------------------------------*
      *   11/16/2009 - RADIOPH-APC-FLAG CHECK REMOVED B/C NO THX    *
      *                RADIOPHARMS HAVE SI=H FOR CY 2010            *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 AND
                PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' H'

                  PERFORM 13665-SET-PTD-LINE-FLAG
                     THRU 13665-SET-PTD-LINE-FLAG-EXIT

                  IF PTD-LINE-FLAG = 'Y'
                     MOVE OPPS-HCPCS (LN-SUB) TO W-PTD-LINE-HCPCS
                     PERFORM 13390-PASS-THRU-DEVICES
                        THRU 13390-PASS-THRU-DEVICES-EXIT
                  END-IF

             END-IF.



      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR ' L' OR
                ' N' OR ' P' OR ' R' OR ' S' OR ' T' OR ' U' OR
                ' V' OR ' X' OR ' W' OR ' Y' OR ' Z' OR ' M') THEN
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 13150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 13150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF ( OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR

      *--------------------------------------------------------*
      *   LINE IS DENIED OR REJECTED AND HAS A PHP OR MH HCPCS *
      *--------------------------------------------------------*
                        OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND

                            ( PHP-HCPCS-FLAG = 'Y' OR
                              MH-HCPCS-FLAG  = 'Y' ) ) OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                      ( OPPS-LITEM-ACT-FLAG (LN-SUB) = '1' )



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      * 11/03/2008 - REMOVED PAFS 91 - 99 FOR COMPOSITES FOR CY 2009*
      * 04/11/2011 - ADDED ' 9' & '10' AS VALID PAFS FOR CY 2011    *
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8' OR ' 9' OR '10'


      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *                                                             *
      *   ** SITE OF SERVICE FLAG = PAYMENT METHOD FLAG IN OCE **   *
      *                                                             *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', PHP APC IS ON THE CURRENT LINE       *
      *-------------------------------------------------------------*
      * 11/06/2007 - CHANGED PHP HEALTH CODES LISTED FROM           *
      *              APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008   *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION APC FROM       *
      *              0033 TO 0172 & 0173 FOR CY 2009, FLAG CHANGED  *
      *              FROM APC33-FLAG TO PHP-APC-FLAG                *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID & PHP APC ON CLAIM - CHECK FURTHER  *
      *-------------------------------------------------------------*
                            ( (PHP-APC-FLAG = 'Y') AND

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, PHP APC ON CLAIM, & LINE APC IS PHP*
      *-------------------------------------------------------------*
                                ( (OPPS-SRVC-IND (LN-SUB) = ' P') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, PHP APC ON CLAIM, & LINE PHP HCPCS *
      *-------------------------------------------------------------*
                                  (PHP-HCPCS-FLAG = 'Y') ) )



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE ALL PACKAGED COMPOSITE LINES                      *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *   11/12/2008 - CHANGED LOGIC THAT EXCLUDES ALL COMPOSITE    *
      *                LINES & MENTAL HEALTH PKG LINES TO USE THE   *
      *                COMPOSITE ADJUSTMENT FLAG INSTEAD OF PAYMENT *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *-------------------------------------------------------------*
                IF (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                   (OPPS-COMP-ADJ-FLAG (LN-SUB) = '00')
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED MENTAL HEALTH LINE CHARGES            *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2008 - LOGIC DISABLED B/C MENTAL HEALTH COMPOSITE   *
      *                LINES ARE NOW IDENTIFIED WITH THE COMPOSITE  *
      *                ADJUSTMENT FLAG JUST AS ALL OTHER COMPOSITES *
      *                (MENTAL HEALTH COMPOSITE LINES NOW HAVE A    *
      *                 PACKAGING FLAG OF '1' (CY 2009)             *
      *-------------------------------------------------------------*
      *         IF (APC34-FLAG = 'Y') AND
      *            (OPPS-SRVC-IND (LN-SUB) = ' N') AND
      *            (OPPS-PKG-FLAG (LN-SUB) = '1')
      *               COMPUTE H-TOT-MH-CHRG = H-SUB-CHRG +
      *                                       H-TOT-MH-CHRG
      *         END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME (PACKAGED) COMPOSITE APC CHARGES     *
      *   FOR EACH COMPOSITE APC BY THE COMPOSITE ADJUSTMENT FLAG   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2007 - LOGIC REVISED FOR CY 2009 TO IDENTIFY ALL    *
      *                COMPOSITE LINES USING THE COMPOSITE          *
      *                ADJUSTMENT FLAG INSTEAD OF PAYMENT           *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *                (INCLUDES PROCESSING FOR MENTAL HEALTH       *
      *                 COMPOSITES)                                 *
      *-------------------------------------------------------------*
                IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "00" AND
                   OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "  " AND
                   OPPS-SRVC-IND (LN-SUB) = ' N'
                      PERFORM 13170-COMPOSITES
                         THRU 13170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   RETURN ERROR CODE WHEN PACKAGED LINE OR LINE APC = 0000   *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 13150-INIT-EXIT
                END-IF


      ***************************************************************
      *   APPLY STEREOTACTIC RADIOSURGERY (SRS) PAYMENT CAP POLICY: *
      *   WHEN APPLICABLE, CHANGE SRS HCPCS 77371'S APC ASSIGNMENT  *
      *   TO '00067' TO CAP PAYMENT AT APC 00067'S RATE             *
      *-------------------------------------------------------------*
      *   02/08/2013 - LOGIC ADDED FOR APRIL 2013 RELEASE           *
      ***************************************************************
                IF OPPS-LITEM-DOS (LN-SUB) >= 20130401 AND
                   OPPS-HCPCS (LN-SUB) = '77371'
                      PERFORM 13176-APPLY-SRS-CAP
                         THRU 13176-APPLY-SRS-CAP-EXIT
                END-IF


      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 13150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 13175-APC-LOOKUP

      *-------------------------------------------------------------*
      *   REDUCE APC PMT BY REDUCED UPDATE RATIO WHEN APPROPRIATE   *
      *   11/13/2009 - NEW FOR CY 2009 (QUALITY)                    *
      *-------------------------------------------------------------*
                      PERFORM 13180-REDUCE-APC-PYMT
                         THRU 13180-REDUCE-APC-PYMT-EXIT



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 13150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 13150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 13150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 13150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 13150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 13150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF LINES ELIGIBLE FOR DEVICE CREDIT *
      * WHEN DEVICE CREDIT IS > $0 AND LINE APC IS A DEVICE         *
      * DEPENDENT APC LISTED IN DEVICE CREDIT CAP TABLE             *
      ***************************************************************
             IF DEVCR-CLAIM-FLAG = 'Y'
                SEARCH ALL DEV-CR14
                    AT END
                       CONTINUE
                    WHEN DEV-APC14 (DEV-INDX14) = OPPS-APC (LN-SUB)
                       COMPUTE H-TOT-DEVCR-PYMTS =
                               H-TOT-DEVCR-PYMTS +
                               H-APC-PYMT.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                PERFORM 13300-COIN-DEDUCT
                   THRU 13300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2009.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                SET W14BD-INDX TO 1
                SEARCH W14BD-ENTRY VARYING W14BD-INDX
                   AT END
                      GO TO 13150-INIT-EXIT
                   WHEN W-2014-BLOOD-HCPCS (W14BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-2014-BLOOD-RANK (W14BD-INDX) TO H-BLOOD-RANK
                     MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                     PERFORM 13375-BLOOD-DEDUCT
                        THRU 13375-BLOOD-DEDUCT-EXIT
                    END-IF.

       13150-INIT-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *     PROCESS LINES WITH A NUCLEAR MEDICINE APC FOR THE       *
      *              PASS-THROUGH RADIOPHARM OFFSET                 *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE PTROFFST FOR LINE APC & LINE YEAR       *
      *      - IF FOUND, ADD A RECORD TO TABLE W-NUCMED-APC-TBL     *
      *        FOR EVERY UNIT.                                      *
      *                                                             *
      *  02/10/2009 - LOGIC ADDED EFFECTIVE STARTING APRIL 2009     *
      *                                                             *
      ***************************************************************
       13165-PROCESS-NUCLEAR-MED.

      *-------------------------------------------------------------*
      * HOLD THE LINE'S APC, UNITS, & SERVICE FROM DATE             *
      *-------------------------------------------------------------*
             MOVE OPPS-GRP (LN-SUB)        TO W-NUCMED-LINE-APC.
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO W-NUCMED-UNIT-CNT.
             MOVE OPPS-LITEM-DOS (LN-SUB)  TO W-LINE-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT RADIOPHARM OFFSET TABLE FOR THE APC & YEAR        *
      *-------------------------------------------------------------*
             SET PTRO-INDX TO 1.
             SEARCH PTRO-ENTRY
              AT END
                 GO TO 13165-PROCESS-NUCLEAR-MED-EXIT

      *-------------------------------------------------------------*
      * WHEN APC & YEAR FOUND, WAGE ADJUST OFFSET & ADD NEW RECORD  *
      * TO NUCLEAR MEDICINE TABLE FOR EVERY UNIT                    *
      *-------------------------------------------------------------*
              WHEN PTRO-NUCMED-APC (PTRO-INDX) = W-NUCMED-LINE-APC AND
                   PTRO-EFF-YEAR (PTRO-INDX) = W-LINE-SRVC-YEAR
                     MOVE PTRO-OFFSET-AMT (PTRO-INDX) TO W-NUCMED-OFFSET
                     COMPUTE W-NUCMED-WA-OFFSET ROUNDED =
                             W-NUCMED-OFFSET * (.6 * A-WINX + .4)
                     PERFORM 13166-LOAD-NUCMED-TABLE
                        THRU 13166-LOAD-NUCMED-TABLE-EXIT
                        VARYING W-NUCMED-SUB FROM 1 BY 1
                        UNTIL W-NUCMED-SUB > W-NUCMED-UNIT-CNT.

       13165-PROCESS-NUCLEAR-MED-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * LOAD A NUCLEAR MEDICINE APC TABLE RECORD FOR EVERY UNIT OF  *
      * THE NUCLEAR MEDICINE LINE AND WAGE ADJUST 60% OF THE OFFSET *
      * (INSERT THE NEW RECORD IN THE CORRECT TABLE POSITION -      *
      *  HIGHEST TO LOWEST OFFSET)                                  *
      *                                                             *
      ***************************************************************
       13166-LOAD-NUCMED-TABLE.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-NUCMED-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW (LAST) ENTRY POSITION (EMPTY RECORD)        *
      *-------------------------------------------------------------*
             SET W-NUCMED-INDX TO W-NUCMED-MAX.
             INITIALIZE W-NUCMED-APC-ENTRY (W-NUCMED-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW NUCMED APC ENTRY FOR THE CURRENT    *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS OFFSET VALUE - HIGHEST TO LOWEST OFFSET                 *
      *-------------------------------------------------------------*
             PERFORM 13167-STAGE-NUCMED-ENTRY
                THRU 13167-STAGE-NUCMED-ENTRY-EXIT
                  UNTIL W-NUCMED-INDX = 1 OR
                     W-NUCMED-WA-OFFSET NOT >
                        W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE W-NUCMED-LINE-APC TO W-NUCMED-APC (W-NUCMED-INDX).
             MOVE W-NUCMED-WA-OFFSET TO
                  W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX).

       13166-LOAD-NUCMED-TABLE-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING NUCMED APC RECORD WITH A HIGHER OFFSET    *
      * DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE   *
      * NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.       *
      *                                                             *
      ***************************************************************
       13167-STAGE-NUCMED-ENTRY.

             MOVE W-NUCMED-APC-ENTRY (W-NUCMED-INDX - 1) TO
                  W-NUCMED-APC-ENTRY (W-NUCMED-INDX).
             SET W-NUCMED-INDX DOWN BY 1.

       13167-STAGE-NUCMED-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  PROCESS LINES WITH A PASS-THROUGH CONTRAST AGENT PROCEDURE *
      *        APC FOR THE PASS-THROUGH CONTRAST AGENT OFFSET       *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE PTCOFFST FOR LINE APC & LINE YEAR       *
      *      - IF FOUND, ADD A RECORD TO TABLE W-CAPROC-APC-TBL     *
      *        FOR EVERY UNIT.                                      *
      *                                                             *
      *  11/16/2009 - LOGIC ADDED EFFECTIVE STARTING JANUARY 2010   *
      *                                                             *
      ***************************************************************
       13168-PROCESS-PTCA-PROC.

      *-------------------------------------------------------------*
      * HOLD THE LINE'S APC, UNITS, & LINE ITEM DATE OF SERVICE     *
      *-------------------------------------------------------------*
             MOVE OPPS-GRP (LN-SUB)        TO W-CAPROC-LINE-APC.
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO W-CAPROC-UNIT-CNT.
             MOVE OPPS-LITEM-DOS (LN-SUB)  TO W-CAPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT CONTRAST AGENT OFFSET TABLE FOR THE APC & YEAR    *
      *-------------------------------------------------------------*
             SET PTCO-INDX TO 1.
             SEARCH PTCO-ENTRY
              AT END
                 GO TO 13168-PROCESS-PTCA-PROC-EXIT

      *-------------------------------------------------------------*
      * WHEN APC & YEAR FOUND, WAGE ADJUST OFFSET & ADD NEW RECORD  *
      * TO PT CONTRAST PROCEDURE APC TABLE FOR EVERY UNIT           *
      *-------------------------------------------------------------*
              WHEN PTCO-CONTR-APC (PTCO-INDX) = W-CAPROC-LINE-APC AND
                   PTCO-EFF-YEAR (PTCO-INDX) = W-CAPROC-SRVC-YEAR
                     MOVE PTCO-OFFSET-AMT (PTCO-INDX) TO W-CAPROC-OFFSET
                     COMPUTE W-CAPROC-WA-OFFSET ROUNDED =
                             W-CAPROC-OFFSET * (.6 * H-WINX + .4)
                     PERFORM 13168-LOAD-PTCA-PROC-TABLE
                        THRU 13168-LOAD-PTCA-PROC-TABLE-EXT
                        VARYING W-CAPROC-SUB FROM 1 BY 1
                        UNTIL W-CAPROC-SUB > W-CAPROC-UNIT-CNT.

       13168-PROCESS-PTCA-PROC-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * LOAD A PT CONTRAST AGENT PROCEDURE APC TABLE RECORD FOR     *
      * EVERY UNIT OF THE PT CONTRAST AGENT PROCEDURE LINE          *
      * (INSERT THE NEW RECORD IN THE CORRECT TABLE POSITION -      *
      *  EARLIEST TO LATEST LIDOS, THEN HIGHEST TO LOWEST OFFSET)   *
      *                                                             *
      ***************************************************************
       13168-LOAD-PTCA-PROC-TABLE.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CAPROC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW (LAST) ENTRY POSITION (EMPTY RECORD)        *
      *-------------------------------------------------------------*
             SET W-CAPROC-INDX TO W-CAPROC-MAX.
             INITIALIZE W-CAPROC-APC-ENTRY (W-CAPROC-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW CAPROC APC ENTRY FOR THE CURRENT    *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS LIDOS & OFFSET VALUE (EARLIEST TO LATEST, HIGHEST TO    *
      * LOWEST)                                                     *
      *-------------------------------------------------------------*
             PERFORM 13168-STAGE-PTCA-PROC-ENTRY
                THRU 13168-STAGE-PTCA-PROC-ENTRY-EX
                  UNTIL W-CAPROC-INDX = 1 OR
                     W-CAPROC-KEY NOT >
                        W-CAPROC-TBL-KEY (W-CAPROC-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE W-CAPROC-LINE-APC TO W-CAPROC-APC (W-CAPROC-INDX).
             MOVE W-CAPROC-KEY TO W-CAPROC-TBL-KEY (W-CAPROC-INDX).

       13168-LOAD-PTCA-PROC-TABLE-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING NUCMED APC RECORD WITH A HIGHER OFFSET    *
      * DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE   *
      * NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.       *
      *                                                             *
      ***************************************************************
       13168-STAGE-PTCA-PROC-ENTRY.

             MOVE W-CAPROC-APC-ENTRY (W-CAPROC-INDX - 1) TO
                  W-CAPROC-APC-ENTRY (W-CAPROC-INDX).
             SET W-CAPROC-INDX DOWN BY 1.

       13168-STAGE-PTCA-PROC-ENTRY-EX.
             EXIT.


      ***************************************************************
      *                                                             *
      *  PROCESS LINES WITH A PASS-THROUGH DEVICE PROCEDURE         *
      *        APC FOR THE PASS-THROUGH DEVICE OFFSET               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE OPPSPTDO FOR LINE APC                   *
      *      - IF FOUND, DETERMINE IF IT MAPS TO A PASS-THROUGH     *
      *        DEVICE HCPCS, HOW MANY IT MAPS TO, IF SOM STORE      *
      *        IT IN THE PASS-THROUGH DEVICE OFFSET PROCEDURE TABLE *
      *                                                             *
      *  08/02/2010 - LOGIC ADDED EFFECTIVE STARTING OCTOBER 2010   *
      *  12/20/2011 - LOGIC REVISED TO INCLUDE TERMINATION DATE     *
      *               AS A VALID DATE OF SERVICE                    *
      *                                                             *
      ***************************************************************
       13169-PROCESS-PTDO-PROC.

      *-------------------------------------------------------------*
      * INITIALIZE VARIBLES SPECIFIC TO THE CURRENT PROCEDURE LINE  *
      *-------------------------------------------------------------*
             MOVE 1 TO W-DOPROC-SUB.
             PERFORM UNTIL W-DOPROC-SUB > W-PTDO-ASSOC-HCPCS-MAX
                INITIALIZE W-PTDO-ASSOC-HCPCS-HCPCS (W-DOPROC-SUB)
                INITIALIZE W-PTDO-ASSOC-HCPCS-IND (W-DOPROC-SUB)
                ADD 1 TO W-DOPROC-SUB
             END-PERFORM.
             SET W-PTDO-ASSOC-HCPCS-INDX TO 1.
             MOVE 0 TO W-PTDO-ASSOC-HCPCS-MAX.
             MOVE 'N' TO W-PTDO-EOF-SWITCH.
             INITIALIZE H-PTDO-ASSOC-HCPCS-CTR.
             INITIALIZE H-PTDO-PROC-KEY.
             INITIALIZE W-PTDO-DARRAY-MAX.
             SET PTDO-INDX TO 1.

      *-------------------------------------------------------------*
      * HOLD THE LINE'S APC, UNITS, & LINE ITEM DATE OF SERVICE     *
      *-------------------------------------------------------------*
             MOVE OPPS-GRP (LN-SUB)        TO W-DOPROC-LINE-APC.
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-PTDO-PROC-UNITS.
             MOVE OPPS-LITEM-DOS (LN-SUB)  TO W-DOPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT DEVICE OFFSET TBL FOR EVERY OCCURANCE OF THE APC  *
      * AND CAPTURE EACH ASSOCIATED DEVICE HCPCS                    *
      *-------------------------------------------------------------*

             PERFORM UNTIL W-PTDO-EOF-SWITCH = 'Y'
             SEARCH PTDO-ENTRY
              AT END
                 MOVE 'Y' TO W-PTDO-EOF-SWITCH

      *-------------------------------------------------------------*
      * EACH TIME A CURRENT RECORD FOR THE APC IS FOUND, ADD THE    *
      * ASSOCIATED HCPCS TO A TABLE, HOLD THE OFFSET AMOUNT, AND    *
      * SEARCH FOR ANOTHER CURRENT RECORD                           *
      *-------------------------------------------------------------*
              WHEN (PTDO-PROC-APC (PTDO-INDX) = W-DOPROC-LINE-APC) AND
                   (PTDO-EFF-DATE (PTDO-INDX) <= W-DOPROC-SRVC-DATE) AND
                   (PTDO-TERM-DATE (PTDO-INDX) = 0 OR
                    PTDO-TERM-DATE (PTDO-INDX) >= W-DOPROC-SRVC-DATE)

                     MOVE 'N' TO W-PTDO-EOF-SWITCH

                     COMPUTE H-PTDO-PROC-WA-OFFSET =
                       ((PTDO-OFFSET-AMT (PTDO-INDX) * .60) * H-WINX) +
                        (PTDO-OFFSET-AMT (PTDO-INDX) * .40)

                     PERFORM 13169-LOAD-ASSOC-PTD-HCPCS
                        THRU 13169-LOAD-ASSOC-PTD-HCPCS-EXT

                     SET PTDO-INDX UP BY 1

             END-SEARCH
             END-PERFORM.

      *-------------------------------------------------------------*
      * SEARCH THE DEVICE OFFSET HCPCS TABLE FOR EACH HCPCS IN      *
      * THE PT DEVICE ASSOCIATED HCPCS TABLE & TRY TO MAP THE HCPCS *
      * TO THE PROCEDURE APC                                        *
      *-------------------------------------------------------------*
             IF W-PTDO-ASSOC-HCPCS-MAX > 0
                PERFORM 13169-COUNT-PTDO-MAPPINGS
                   THRU 13169-COUNT-PTDO-MAPPINGS-EXIT
                   VARYING W-DOPROC-SUB FROM 1 BY 1
                   UNTIL W-DOPROC-SUB > W-PTDO-ASSOC-HCPCS-MAX
             END-IF.

      *-------------------------------------------------------------*
      * CREATE RECORD IN THE OFFSET PROCEDURE APC TABLE IF          *
      * PROCEDURE HAS >= 1 ASSOCIATED DEVICE HCPCS ON THE CLAIM     *
      *-------------------------------------------------------------*
             IF H-PTDO-ASSOC-HCPCS-CTR > 0
                PERFORM 13169-LOAD-PTDO-PROC-TABLE
                   THRU 13169-LOAD-PTDO-PROC-TABLE-EXT
             END-IF.


       13169-PROCESS-PTDO-PROC-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * LOAD THE PASS-THROUGH DEVICE HCPCS ON THE RECORD INTO THE   *
      * PTDO ASSOCIATED HCPCS TABLE                                 *
      *                                                             *
      ***************************************************************
       13169-LOAD-ASSOC-PTD-HCPCS.

      *-------------------------------------------------------------*
      * DETERMINE IF THE RECORD'S PTDO HCPCS IS ALREADY IN THE TBL  *
      * IF IT'S NOT IN THE TBL, ADD IT, IF IT IS, DO NOT ADD IT     *
      *-------------------------------------------------------------*
             SET W-PTDO-ASSOC-HCPCS-INDX TO 1.
             SEARCH W-PTDO-ASSOC-HCPCS-ENTRY
              AT END
                 MOVE PTDO-DEV-HCPCS (PTDO-INDX) TO
                      W-PTDO-ASSOC-HCPCS-HCPCS (W-PTDO-ASSOC-HCPCS-INDX)
                 ADD 1 TO W-PTDO-ASSOC-HCPCS-MAX
                 ADD 1 TO W-PTDO-DARRAY-MAX

              WHEN W-PTDO-ASSOC-HCPCS-HCPCS(W-PTDO-ASSOC-HCPCS-INDX)
                   = PTDO-DEV-HCPCS (PTDO-INDX)
                   GO TO 13169-LOAD-ASSOC-PTD-HCPCS-EXT
              END-SEARCH.

       13169-LOAD-ASSOC-PTD-HCPCS-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE HOW MANY PT DEVICE OFFSET HCPCS MAP TO THE OFFSET *
      * PROCEDURE, AND HOW MANY PROCEDURES MAP TO THE DEVICE HCPCS  *
      *                                                             *
      ***************************************************************
       13169-COUNT-PTDO-MAPPINGS.

      *-------------------------------------------------------------*
      * SEARCH PT DEVICE OFFSET HCPCS TBL FOR THE CURRENT DEVICE    *
      * HCPCS (IN THE ASSOC. HCPCS TBL)                             *
      *-------------------------------------------------------------*
             SET W-PTDO-HCPCS-INDX TO 1.
             SEARCH W-PTDO-HCPCS-ENTRY
              AT END
                 MOVE 'N' TO W-PTDO-ASSOC-HCPCS-IND(W-DOPROC-SUB)

              WHEN W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX) =
                   W-PTDO-ASSOC-HCPCS-HCPCS(W-DOPROC-SUB)
                   MOVE 'Y' TO W-PTDO-ASSOC-HCPCS-IND(W-DOPROC-SUB)
                   ADD 1 TO H-PTDO-ASSOC-HCPCS-CTR
                   ADD 1 TO W-PTDO-HCPCS-PROC-CNT(W-PTDO-HCPCS-INDX).

       13169-COUNT-PTDO-MAPPINGS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * LOAD A PT DEVICE OFFSET PROCEDURE APC TABLE RECORD FOR      *
      * THE CURRENT PROCEDURE LINE IF THERE IS AT LEAST ONE         *
      * ASSOCIATED PT DEVICE ON THE CLAIM                           *
      * (INSERT THE NEW RECORD IN THE CORRECT TABLE POSITION -      *
      *  HIGHEST TO LOWEST OFFSET, THEN HIGHEST TO LOWEST UNITS)    *
      *                                                             *
      ***************************************************************
       13169-LOAD-PTDO-PROC-TABLE.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTDO-PROC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW (LAST) ENTRY POSITION (EMPTY RECORD)        *
      *-------------------------------------------------------------*
             SET W-PTDO-PROC-INDX TO W-PTDO-PROC-MAX.
      *      INITIALIZE W-PTDO-PROC-ENTRY (W-PTDO-PROC-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW PROC APC ENTRY FOR THE CURRENT      *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS OFFSET & UNITS (HIGHEST TO LOWEST, HIGHEST TO LOWEST)   *
      *-------------------------------------------------------------*
             PERFORM 13169-STAGE-PTDO-PROC-ENTRY
                THRU 13169-STAGE-PTDO-PROC-ENTRY-EX
                  UNTIL W-PTDO-PROC-INDX = 1 OR
                     H-PTDO-PROC-KEY NOT >
                        W-PTDO-PROC-KEY (W-PTDO-PROC-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE W-DOPROC-LINE-APC TO
                  W-PTDO-PROC-APC (W-PTDO-PROC-INDX).
             MOVE LN-SUB TO W-PTDO-PROC-LNSUB (W-PTDO-PROC-INDX).
             MOVE H-PTDO-PROC-UNITS TO
                  W-PTDO-PROC-UNITS (W-PTDO-PROC-INDX).
             MOVE H-PTDO-PROC-WA-OFFSET TO
                  W-PTDO-PROC-WA-OFFSET (W-PTDO-PROC-INDX).
             MOVE 0 TO W-PTDO-PROC-DEVICE-CNT (W-PTDO-PROC-INDX).
             MOVE 0 TO W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX).
             MOVE 0 TO W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX).
             MOVE SPACES TO W-PTDO-PROC-USED (W-PTDO-PROC-INDX).

      *------------------------------------------------------------*
      * LOAD HCPCS IN ASSOCIATED HCPCS TABLE INTO THE EMPTY RECORD *
      *------------------------------------------------------------*
             MOVE 1 TO W-DOPROC-SUB.
             MOVE 0 TO W-PTDO-DARRAY-SIZE (W-PTDO-PROC-INDX).
             PERFORM UNTIL W-DOPROC-SUB > W-PTDO-ASSOC-HCPCS-MAX
               IF W-PTDO-ASSOC-HCPCS-IND (W-DOPROC-SUB) = 'Y'
                MOVE W-PTDO-ASSOC-HCPCS-HCPCS (W-DOPROC-SUB) TO
                  W-PTDO-PROC-DHCPCS (W-PTDO-PROC-INDX, W-DOPROC-SUB)
                ADD 1 TO W-PTDO-DARRAY-SIZE (W-PTDO-PROC-INDX)
               END-IF
               ADD 1 TO W-DOPROC-SUB
             END-PERFORM.


       13169-LOAD-PTDO-PROC-TABLE-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING PROCEDURE RECORD WITH A LOWER OFFSET &    *
      * LOWER UNITS DOWN ONE RECORD POSITION AND SET THE EMPTY      *
      * RECORD FOR THE NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD  *
      * POSITION.                                                   *
      *                                                             *
      ***************************************************************
       13169-STAGE-PTDO-PROC-ENTRY.

             MOVE W-PTDO-PROC-ENTRY (W-PTDO-PROC-INDX - 1) TO
                  W-PTDO-PROC-ENTRY (W-PTDO-PROC-INDX).
             SET  W-PTDO-PROC-INDX DOWN BY 1.

       13169-STAGE-PTDO-PROC-ENTRY-EX.
             EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH COMPOSITE          *
      *  ADJUSTMENT FLAG NOT = '00' & POPULATE COMPOSITE APC TABLE  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY COMPOSITE ADJUSTMENT FLAG (CAF) -   *
      *    LOWEST TO HIGHEST FLAG VALUE (01 - NN)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH CAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *  11/12/2008 - LOGIC REVISED FOR CY 2009 TO USE THE          *
      *               COMPOSITE ADJUSTMENT FLAG INSTEAD OF THE      *
      *               PAYMENT ADJUSTMENT FLAG, VARIABLE H-CMP-CAF   *
      *               HOLDS COMPOSITE ADJUSTMENT FLAG, VARIABLE     *
      *               W-CMP-PAF RETAINED AND NOW HOLDS THE CAF      *
      *               (RETAINED TO CONTINUE USE OF EXISTING TABLE)  *
      *                                                             *
      ***************************************************************
       13170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S COMPOSITE ADJUSTMENT FLAG FOR TABLE SEARCH   *
      *-------------------------------------------------------------*
             MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE CAF         *
      *-------------------------------------------------------------*
                PERFORM 13171-SEARCH-CAF
                   THRU 13171-SEARCH-CAF-EXIT.

       13170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       13171-SEARCH-CAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS NOT      *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 13172-ADD-ENTRY
                      THRU 13172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS ALREADY  *
      * IN THE TABLE, UPDATE THE ENTRY                              *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                   PERFORM 13173-UPDATE-ENTRY
                      THRU 13173-UPDATE-ENTRY-EXIT.

       13171-SEARCH-CAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       13172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS COMPOSITE ADJUSTMENT FLAG (CAF) - LOWEST TO HIGHEST CAF *
      *-------------------------------------------------------------*
             PERFORM 13174-STAGE-CMP-ENTRY
                THRU 13174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-CAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-CAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       13172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * COMPOSITE ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE       *
      *                                                             *
      ***************************************************************
       13173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE CAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       13173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER CAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       13174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       13174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       13175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 13175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       13175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   APPLY STEREOTACTIC RADIOSURGERY (SRS) CAP POLICY:         *
      *   WHEN APPLICABLE, CHANGE SRS HCPCS 77371'S APC ASSIGNMENT  *
      *   TO '00067' TO CAP PAYMENT AT APC 00067'S RATE             *
      *                                                             *
      *  PROVIDER TYPES EXEMPT FROM THIS POLICY:                    *
      *    - LOCATED IN RURAL AREA                                  *
      *    - RURAL REFERRAL CENTER                                  *
      *    - SOLE COMMUNITY HOSPITAL                                *
      *                                                             *
      *  02/08/2013 - CREATED THIS PARAGRAPH                        *
      *                                                             *
      ***************************************************************
       13176-APPLY-SRS-CAP.

      *-------------------------------------------------------------*
      *  MOVE PROVIDER GEOGRAPHIC AND WAGE INDEX CBSA TO FLAG FIELDS*
      *-------------------------------------------------------------*
             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.

      *-------------------------------------------------------------*
      *  IDENTIFY PROVIDERS EXEMPT FROM THE SRS PAYMENT CAP POLICY: *
      *    1) RURAL: RURAL GEOGRAPHIC OR RURAL WAGE INDEX CBSA      *
      *    2) RURAL REFERRAL CENTER: PROVIDER TYPE 07               *
      *    3) SOLE COMMUNITY HOSPITAL: PROVIDER TYPE 16,17,21,OR 22 *
      *-------------------------------------------------------------*
             IF ((RURAL-GEO OR RURAL-WI) OR
                 (L-PSF-PROV-TYPE = '07') OR
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))
                GO TO 13176-APPLY-SRS-CAP-EXIT

      *-------------------------------------------------------------*
      *  FOR PROVIDERS ELIGIBLE FOR SRS CAP, CHANGE APC TO '00067'  *
      *-------------------------------------------------------------*
             ELSE
                MOVE '00067' TO OPPS-GRP (LN-SUB)
             END-IF.


       13176-APPLY-SRS-CAP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      REDUCE APC PAYMENT OF LINES FROM PROVIDERS WITH A      *
      *      SPACE IN THE QUALITY INDICATOR FIELD OF THE OPSF       *
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      *  11/16/2010 - ADDED SI = U (BRACHY) TO LOGIC                *
      *                                                             *
      ***************************************************************
       13180-REDUCE-APC-PYMT.

      *-------------------------------------------------------------*
      *  SPECIFY LINES ELIGIBLE FOR REDUCTION                       *
      *-------------------------------------------------------------*
             IF ( L-PSF-HOSP-QUAL-IND = ' ' )  AND

                (  (OPPS-SRVC-IND (LN-SUB) = ' P')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' R')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' S' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01491' AND
                           OPPS-GRP (LN-SUB) <= '01537'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' T' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01539' AND
                           OPPS-GRP (LN-SUB) <= '01574'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' U')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' V')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' X')  ) THEN

                COMPUTE H-APC-PYMT ROUNDED = H-APC-PYMT * 0.980
                MOVE 11 TO A-RETURN-CODE (LN-SUB)

             END-IF.


       13180-REDUCE-APC-PYMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DELETED CODE:                                              *
      *    IF DATE OF SERVICE BETWEEN 12/31/2002 AND 04/01/2003     *
      *    IF HCPCS CODE = C9114 OR C9115 ADJUST PAYMENT AND        *
      *    COINSURANCE AMOUNTS - LOGIC REMOVED FOR 20050101         *
      *                                                             *
      ***************************************************************


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       13200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 13200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA

      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 13210-WAGE-LOOKUP.
      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0 OR NOT NUMERIC             *
      ***************************************************************
             IF H-WINX = 0 OR H-WINX NOT NUMERIC THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       13200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       13210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE IS BEFORE OR ON THE       *
      *  LATEST EFFECTIVE DATE THE CLAIM CAN USE - CORRECT          *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD FOR THE CBSA)    *
      ***************************************************************
             IF WCW-DTCD (W-SUB3) NOT > WCD-DTCD (WCD-SUB)

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *-------------------------------------------------------------*
                IF L-PSF-SPEC-PYMT-IND = 'Y'
                   MOVE WCW-WINX2 (W-SUB3) TO H-WINX

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WCW-WINX1 (W-SUB3) TO H-WINX


      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE IS AFTER LATEST EFFECTIVE *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  CBSA WAGE INDEX TABLE.                                     *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 13210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-WINX.

       13210-WAGE-LOOKUP-EXIT.
           EXIT.
      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       13250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 13250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       13250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       13300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 13350-STAGE-ENTRY
                THRU 13350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX      TO W-WINX (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       13300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       13350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       13350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       13375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 13385-STAGE-ENTRY
                THRU 13385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX     TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       13375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       13385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       13385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            POPULATE PASS-THROUGH DEVICE TABLE               *
      *        (FOR ASSOCIATED PROCEDURE PAYMENT & CHARGE           *
      *            ADJUSTMENTS IN THE OUTLIER ROUTINE)              *
      *            (IMPLEMENTED IN APRIL 2008 PRICER)               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER RECORDS AS FOLLOWS -                                 *
      *     1. HCPCS, ASCENDING                                     *
      *     2. LOWEST TO HIGHEST LINE SUBSCRIPT                     *
      *                                                             *
      *  02/11/2008 - LOGIC ADDED FOR CY 2008, QTR 2                *
      *  11/12/2008 - LOGIC NOT CHANGED, NO CY 2009 PT DEVICES      *
      *                                                             *
      ***************************************************************
       13390-PASS-THRU-DEVICES.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-PTD-INDX TO W-PTD-MAX.
             INITIALIZE W-PTD-ENTRY (W-PTD-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW RECORD SHOULD BE ENTERED INTO THE   *
      * TABLE ACCORDING TO ITS HCPCS AND THE HCPCS OF THE RECORDS   *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST HCPCS              *
      *-------------------------------------------------------------*
             PERFORM 13391-STAGE-ENTRY
                THRU 13391-STAGE-ENTRY-EXIT
                   UNTIL W-PTD-INDX = 1 OR
                     W-PTD-LINE-HCPCS NOT <
                       W-PTD-HCPCS (W-PTD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE OPPS-HCPCS (LN-SUB)    TO W-PTD-HCPCS (W-PTD-INDX).
             MOVE LN-SUB                 TO W-PTD-SUB (W-PTD-INDX).
             MOVE OPPS-SUB-CHRG (LN-SUB) TO W-PTD-SUB-CHRG (W-PTD-INDX).

       13390-PASS-THRU-DEVICES-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING PASS-THROUGH DEVICE RECORD WITH A       *
      *   HIGHER HCPCS UP ONE RECORD POSITION AND SET THE INDEX OF  *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       13391-STAGE-ENTRY.

             MOVE W-PTD-ENTRY (W-PTD-INDX - 1) TO
                  W-PTD-ENTRY (W-PTD-INDX).
             SET W-PTD-INDX DOWN BY 1.

       13391-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE DATA     *
      *              (IMPLEMENTED IN APRIL 2008 PRICER)             *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  02/11/2008 - LOGIC ADDED FOR CY 2008, QTR 2                *
      *                                                             *
      ***************************************************************
       13392-PASS-THRU-DEV-PROCS.

      *-------------------------------------------------------------*
      * LOOP THROUGH ELIGIBLE PROCEDURE'S PASS-THROUGH DEVICE TABLE *
      *-------------------------------------------------------------*
             PERFORM 13393-PERFORM-SEARCH
                THRU 13393-PERFORM-SEARCH-EXIT
                VARYING W-PTD-PROC-SUB FROM 1 BY 1
                UNTIL W-PTD-PROC-SUB > W-PTD-CNT.

       13392-PASS-THRU-DEV-PROCS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE                                    *
      *                                                             *
      ***************************************************************
       13393-PERFORM-SEARCH.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR ALL OCCURANCES    *
      * OF THE PASS-THRU DEVICE HCPCS IN THE PASS-THRU DEVICE TABLE.*
      * THIS IS DONE FOR ALL PASS-THROUGH DEVICES THE PROCEDURE IS  *
      * ELIGIBLE FOR.                                               *
      *-------------------------------------------------------------*
                 MOVE 'N' TO W-END-OF-PTD-TBL.

                 IF W-PTD-PROC-HCPCS (W-PTD-PROC-SUB) NOT = '     '
                    SET W-PTD-INDX TO 1
                    PERFORM 13394-SEARCH-PTD-HCPCS
                       THRU 13394-SEARCH-PTD-HCPCS-EXIT
                      UNTIL W-END-OF-PTD-TBL = 'Y'
                 END-IF.

       13393-PERFORM-SEARCH-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE                                    *
      *                                                             *
      ***************************************************************
       13394-SEARCH-PTD-HCPCS.

             MOVE 'N' TO W-END-OF-PTD-TBL.

      *-------------------------------------------------------------*
      * SEARCH PASS-THROUGH DEVICE TABLE                            *
      *-------------------------------------------------------------*
             SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THERE ARE NO MORE OCCURANCES OF THE PASS-THROUGH DEVICE, *
      * STOP THE SEARCH AND INDICATE END OF FILE                    *
      *-------------------------------------------------------------*
                AT END
                   MOVE 'Y' TO W-END-OF-PTD-TBL
                   GO TO 13394-SEARCH-PTD-HCPCS-EXIT

      *-------------------------------------------------------------*
      * IF THE PASS-THROUGH DEVICE IS FOUND, INDICATE NOT END OF    *
      * FILE AND UPDATE THE DEVICE'S RECORD WITH THE PROCEDURE DATA *
      *-------------------------------------------------------------*
                WHEN  W-PTD-HCPCS (W-PTD-INDX) =
                      W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)

                         MOVE 'N' TO W-END-OF-PTD-TBL

                         PERFORM 13395-UPDATE-ENTRY
                            THRU 13395-UPDATE-ENTRY-EXIT

                         SET W-PTD-INDX UP BY 1

             END-SEARCH.

       13394-SEARCH-PTD-HCPCS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING PASS-THROUGH DEVICE RECORD WITH THE     *
      * CURRENT ELIGIBLE PROCEDURE'S DATA                           *
      *                                                             *
      ***************************************************************
       13395-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * UPDATE PASS-THROUGH DEVICE RECORD                           *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTD-PROC-CNT (W-PTD-INDX).

             ADD OPPS-SRVC-UNITS (LN-SUB) TO
                 W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX).

       13395-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SUM PASS-THROUGH CONTRAST AGENT OFFSET AMOUNT(S) FOR EACH   *
      * DAY ON WHICH A PASS-THROUGH CONTRAST AGENT APPEARS          *
      *                                                             *
      ***************************************************************
       13396-TOTAL-DAY-PTCA-OFFS.

      *-------------------------------------------------------------*
      * CAPTURE DATE OF SERVICE FROM PT CONTRAST AGENT DAY TABLE    *
      *-------------------------------------------------------------*
             MOVE W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX)
               TO W-CAPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * MOVE TO FIRST RECORD IN PT CONTRAST AGENT PROCEDURE APC TBL *
      *-------------------------------------------------------------*
             SET W-CAPROC-INDX TO 1.

      *-------------------------------------------------------------*
      * START COUNTER THAT MONITORS THE # OF OFFSETS ADDED          *
      *-------------------------------------------------------------*
             MOVE 1 TO W-CAPROC-UNIT-CNT.

             SEARCH W-CAPROC-APC-ENTRY

      *-------------------------------------------------------------*
      * DATE OF SERVICE NOT FOUND IN TABLE, STOP PROCESS            *
      *-------------------------------------------------------------*
                AT END
                   GO TO 13396-TOTAL-DAY-PTCA-OFFS-EXIT

      *-------------------------------------------------------------*
      * DATE OF SERVICE FOUND IN TABLE, ACCUMULATE OFFSETS          *
      *-------------------------------------------------------------*
                WHEN W-CAPROC-LIDOS (W-CAPROC-INDX) = W-CAPROC-SRVC-DATE
                     PERFORM UNTIL
      *     *-------------------------------------------------------*
      *     * STOP SEARCH WHEN END OF TABLE REACHED                 *
      *     *-------------------------------------------------------*
                        (W-CAPROC-INDX > W-CAPROC-MAX) OR
      *     *-------------------------------------------------------*
      *     * STOP SEARCH WHEN NUMBER OF DAY'S HCPCS LINES EXCEEDED *
      *     *-------------------------------------------------------*
                        (W-CAPROC-UNIT-CNT >
                           W-PTCA-DAY-HCPCS-CNT (W-PTCA-DAY-INDX)) OR
      *     *-------------------------------------------------------*
      *     * STOP SEARCH WHEN DATE OF SERVICE CHANGES              *
      *     *-------------------------------------------------------*
                        (W-CAPROC-LIDOS (W-CAPROC-INDX) NOT =
                           W-CAPROC-SRVC-DATE)

      *     *-------------------------------------------------------*
      *     * ADD PT CONTRAST AGENT PROCEDURE OFFSET TO DAY TOTAL   *
      *     *-------------------------------------------------------*
                        COMPUTE W-PTCA-DAY-TOT-OFFSET (W-PTCA-DAY-INDX)
                          ROUNDED =
                             W-PTCA-DAY-TOT-OFFSET (W-PTCA-DAY-INDX) +
                             W-CAPROC-WAGE-ADJ-OFFSET (W-CAPROC-INDX)

      *     *-------------------------------------------------------*
      *     * SET POINTER TO NEXT PROCEDURE RECORD                  *
      *     *-------------------------------------------------------*
                        SET W-CAPROC-INDX UP BY 1
                        ADD 1 TO W-CAPROC-UNIT-CNT
                     END-PERFORM
             END-SEARCH.

       13396-TOTAL-DAY-PTCA-OFFS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MAP EACH PT DEVICE HCPCS ON THE CLAIM TO AN OFFSET          *
      * PROCEDURE WHEN POSSIBLE - FIRST PASS: ASSIGN EACH PROCEDURE *
      * ONLY ONE PT DEVICE                                          *
      *                                                             *
      ***************************************************************
       13397-PTDO-MAPPINGS-1.

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLES SPECIFIC TO THIS PT HCPCS RECORD       *
      *-------------------------------------------------------------*
             MOVE 'N' TO W-PTDO-EOF-SWITCH.
             SET W-PTDO-PROC-INDX TO 1.

      *-------------------------------------------------------------*
      * SEARCH PTDO PROCEDURE TABLE FOR A PROCEDURE THAT MAPS TO    *
      * THE CURRENT PT DEVICE                                       *
      *-------------------------------------------------------------*
             PERFORM UNTIL W-PTDO-EOF-SWITCH = 'Y'
             SEARCH W-PTDO-PROC-ENTRY

                AT END
                   MOVE 'Y' TO W-PTDO-EOF-SWITCH
                   GO TO 13397-PTDO-MAPPINGS-1-EXIT

      *-------------------------------------------------------------*
      * PROCEDURE NOT ASSIGNED TO A PT DEVICE, SEE IF IT MAPS       *
      *-------------------------------------------------------------*
                WHEN W-PTDO-PROC-USED (W-PTDO-PROC-INDX) NOT = 'Y'

                   SET W-PTDO-DARRAY-INDX TO 1
                   MOVE W-PTDO-DARRAY-SIZE (W-PTDO-PROC-INDX) TO
                        W-PTDO-DARRAY-MAX

                   SEARCH W-PTDO-PROC-DARRAY
                      AT END
                         CONTINUE

      *-------------------------------------------------------------*
      * PROCEDURE MAPS TO CURRENT PT DEVICE HCPCS                   *
      *-------------------------------------------------------------*
                      WHEN W-PTDO-PROC-DHCPCS (W-PTDO-PROC-INDX,
                                               W-PTDO-DARRAY-INDX) =
                           W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX)

                         MOVE W-PTDO-PROC-APC (W-PTDO-PROC-INDX) TO
                             W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX)

                         MOVE W-PTDO-PROC-LNSUB (W-PTDO-PROC-INDX) TO
                             W-PTDO-HCPCS-PROC-LNSUB (W-PTDO-HCPCS-INDX)

                         MOVE 'Y' TO W-PTDO-PROC-USED (W-PTDO-PROC-INDX)

                         MOVE 1 TO
                             W-PTDO-PROC-DEVICE-CNT (W-PTDO-PROC-INDX)

                         MOVE W-PTDO-HCPCS-SUB-CHRG (W-PTDO-HCPCS-INDX)
                           TO W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX)

                         MOVE W-PTDO-HCPCS-UNITS (W-PTDO-HCPCS-INDX) TO
                             W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX)

                         GO TO 13397-PTDO-MAPPINGS-1-EXIT
                   END-SEARCH
                   SET W-PTDO-PROC-INDX UP BY 1
             END-SEARCH
             END-PERFORM.

       13397-PTDO-MAPPINGS-1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MAP EACH PT DEVICE HCPCS ON THE CLAIM TO AN OFFSET          *
      * PROCEDURE WHEN POSSIBLE - SECOND PASS: ASSIGN PROCEDURES    *
      * ADDITIONAL PT DEVICES WHEN NECESSARY                        *
      *                                                             *
      ***************************************************************
       13397-PTDO-MAPPINGS-2.

      *-------------------------------------------------------------*
      * DETERMINE WHETHER THE PT DEVICE HCPCS NEEDS A PROCEDURE     *
      *-------------------------------------------------------------*
             IF W-PTDO-HCPCS-PROC-CNT (W-PTDO-HCPCS-INDX) > 0 AND
                W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX) = SPACES
                CONTINUE
             ELSE
                GO TO 13397-PTDO-MAPPINGS-2-EXIT
             END-IF.
             SET W-PTDO-PROC-INDX TO 1.

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLES SPECIFIC TO THIS PT HCPCS RECORD       *
      *-------------------------------------------------------------*
             MOVE 'N' TO W-PTDO-EOF-SWITCH.

      *-------------------------------------------------------------*
      * SEARCH PTDO PROCEDURE TABLE FOR A PROCEDURE THAT MAPS TO    *
      * THE CURRENT PT DEVICE                                       *
      *-------------------------------------------------------------*
             PERFORM UNTIL W-PTDO-EOF-SWITCH = 'Y'
             SEARCH W-PTDO-PROC-ENTRY

                AT END
                   MOVE 'Y' TO W-PTDO-EOF-SWITCH
                   GO TO 13397-PTDO-MAPPINGS-2-EXIT

      *-------------------------------------------------------------*
      * PROCEDURE ALREADY ASSIGNED TO PT DEVICE(S)                  *
      *-------------------------------------------------------------*
                WHEN W-PTDO-PROC-USED (W-PTDO-PROC-INDX) = 'Y' OR
                     W-PTDO-PROC-USED (W-PTDO-PROC-INDX) = 'S'

                   SET W-PTDO-DARRAY-INDX TO 1
                   MOVE W-PTDO-DARRAY-SIZE (W-PTDO-PROC-INDX) TO
                        W-PTDO-DARRAY-MAX
                   SEARCH W-PTDO-PROC-DARRAY
                      AT END
                         CONTINUE

      *-------------------------------------------------------------*
      * PROCEDURE MAPS TO CURRENT PT DEVICE HCPCS, SEE IF IT MAPS   *
      *-------------------------------------------------------------*
                      WHEN W-PTDO-PROC-DHCPCS (W-PTDO-PROC-INDX,
                                               W-PTDO-DARRAY-INDX) =
                           W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX)

                         MOVE W-PTDO-PROC-APC (W-PTDO-PROC-INDX) TO
                             W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX)

                         MOVE W-PTDO-PROC-LNSUB (W-PTDO-PROC-INDX) TO
                             W-PTDO-HCPCS-PROC-LNSUB (W-PTDO-HCPCS-INDX)

                         MOVE 'S' TO W-PTDO-PROC-USED (W-PTDO-PROC-INDX)

                         ADD 1 TO
                             W-PTDO-PROC-DEVICE-CNT (W-PTDO-PROC-INDX)

                         COMPUTE W-PTDO-PROC-TOT-DCHRGS
                                 (W-PTDO-PROC-INDX) =
                           W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX) +
                           W-PTDO-HCPCS-SUB-CHRG (W-PTDO-HCPCS-INDX)

                         COMPUTE W-PTDO-PROC-TOT-DUNITS
                                 (W-PTDO-PROC-INDX) =
                           W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX) +
                           W-PTDO-HCPCS-UNITS (W-PTDO-HCPCS-INDX)

                         GO TO 13397-PTDO-MAPPINGS-2-EXIT
                   END-SEARCH
                   SET W-PTDO-PROC-INDX UP BY 1
             END-SEARCH
             END-PERFORM.

       13397-PTDO-MAPPINGS-2-EXIT.
           EXIT.




      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PYMNTS, DEDUCTIBLES, REIM., & COINSURANCE,  *
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       13400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 13400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 13550-CALC-STANDARD
                   THRU 13550-CALC-STANDARD-EXIT
             ELSE
                GO TO 13400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRUG COINSURANCE TABLE FOR LATER PROCESSING        *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET GJK-FLAG WHEN SERVICE = G OR K                       *
      *-------------------------------------------------------------*
             IF (A-RETURN-CODE (LN-SUB) <  30)
                PERFORM 13450-ADJ-PROC-COIN
                   THRU 13450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 13500-ADJ-CHRGS
                THRU 13500-ADJ-CHRGS-EXIT.


      *-------------------------------------------------------------*
      *   UPDATE PASS-THROUGH DEVICE TABLE W/ ELIGIBLE PROCEDURE    *
      *   LINE DATA (FOR ASSOCIATED PROCEDURE OUTLIER CALC)         *
      *   EFFECTIVE CY 2008 QTR 2, LOGIC ADDED 02/12/2008           *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) < 30 AND
                PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR ' X'

                  PERFORM 13670-SET-PTD-PROC-FLAG
                     THRU 13670-SET-PTD-PROC-FLAG-EXIT

                  IF PTD-PROC-FLAG = 'Y'
                     PERFORM 13392-PASS-THRU-DEV-PROCS
                        THRU 13392-PASS-THRU-DEV-PROCS-EXIT
                  END-IF

             END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

                COMPUTE A-DEVICE-CREDIT-QD =
                        A-DEVICE-CREDIT-QD + H-LINE-DEVCR-AMT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 13840-PROCESS-TYPE2     *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)

               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       13400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE DRUG COINSURANCE ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: DRUG / BLOOD LINE                       *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY DRUG LINE          *
      *   ("DRUG" REFERS TO ANY SI = G OR K LINE FOR SIMPLICITY)    *
      *                                                             *
      * DRUG COINSURANCE RECORD COMBINATIONS:                       *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       DRUG(S) ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO DRUG(S) ADMINISTERED ON THE *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH DRUG(S) ADMINISTERED ON THE    *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = G OR K =>          *
      *       DRUG ADMINSTERED ON THE DATE OF SERVICE               *
      *                                                             *
      ***************************************************************
       13450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                PERFORM 13455-SEARCH-KEY
                   THRU 13455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = G, K, & R LINES ("DRUG" & BLOOD)               *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET GJK-FLAG TO INDICATE "DRUG" LINE                        *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO GJK-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                   PERFORM 13455-SEARCH-KEY
                      THRU 13455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY DRUG LINE) *
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = G OR K  *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 13475-STAGE-DCP-ENTRY
                      THRU 13475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, "DRUG"                                       *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       13450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW DRUG/DEVICE COINSURANCE TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       13455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH DRUG/DEVICE COINSURANCE TABLE STARTING AT ENTRY #1   *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 13460-ADD-ENTRY
                      THRU 13460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 13465-UPDATE-ENTRY
                      THRU 13465-UPDATE-ENTRY-EXIT.

       13455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE DRUG / DEVICE COINSURANCE TABLE                         *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       13460-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 13475-STAGE-DCP-ENTRY
                THRU 13475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, "DRUG"                                       *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       13460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING DRUG COINSURANCE RECORD WITH THE SAME   *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       13465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR "DRUG" LINES - ACCUMULATE DAY'S TOTAL "DRUG" COIN DUE   *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A "DRUG" LINE, UPDATE THE RECORD  *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 13485-REPLACE-TYPE1
                     THRU 13485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 13480-RANK-COIN
                     THRU 13480-RANK-COIN-EXIT.

       13465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING DRUG COINSURANCE RECORD WITH A HIGHER     *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       13475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       13475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST WAGE ADJ.  *
      * NATIONAL COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE  *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       13480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       13480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = G OR K   *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = DRUG / BLOOD LINE NEW COINSURANCE AMOUNT(S)       *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       13485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       13485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 13600-ADJ-CHRG-OUTL.)                     *
      *                                                             *
      ***************************************************************
       13500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
      * 12/18/2009 - ADD SIS R & U, WHICH ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P' OR ' R' OR ' U')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       13500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    AND DRUGS & TAKE PT DEVICE OFFSET WHEN APPLICABLE        *
      * 5. CALCULATE AND APPLY DEVICE CREDIT                        *
      *                                                             *
      ***************************************************************
       13550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 13655-SET-BD-HCPCS-FLAG
                THRU 13655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      * FLAG LINE IF LINE HCPCS IS A PASS-THROUGH RADIOPHARM HCPCS  *
      * ** QUARTERLY UPDATES TO TABLE **                            *
      *-------------------------------------------------------------*
      * 02/10/2009 - PT RADIOPHARM HCPCS CHECK ADDED                *
      *-------------------------------------------------------------*
             PERFORM 13680-SET-PTRADIO-LINE-FLAG
                THRU 13680-SET-PTRADIO-LINE-FL-EXIT.

      *-------------------------------------------------------------*
      * FLAG LINE IF LINE HCPCS IS A PASS-THROUGH CONTRAST AGENT    *
      * HCPCS ** QUARTERLY UPDATES TO TABLE **                      *
      *-------------------------------------------------------------*
      * 11/16/2009 - PT CONTRAST AGENT HCPCS CHECK ADDED            *
      *-------------------------------------------------------------*
             PERFORM 13681-SET-PTCA-LINE-FLAG
                THRU 13681-SET-PTCA-LINE-FL-EXIT.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).

      ***************************************************************
      * CALCULATE DEVICE CREDIT FOR ELIGIBLE LINE(S) AND            *
      * REDUCE THE APC PAYMENT BY THE CREDIT AMOUNT                 *
      *-------------------------------------------------------------*
      * 11/18/2013 - NEW LOGIC FOR CY 2014; REPLACES DEVICE         *
      *              REDUCTION LOGIC                                *
      ***************************************************************
             IF DEVCR-CLAIM-FLAG = 'Y'
                PERFORM 13550-DEVICE-CREDIT
                   THRU 13550-DEVICE-CREDIT-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, OR X LINES           *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X') THEN
                  PERFORM 13550-SCH-ADJ
                     THRU 13550-SCH-ADJ-EXIT
                  PERFORM 13560-CALC-BENE-DEDUCT
                     THRU 13560-CALC-BENE-DEDUCT-EXIT

                  IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                     PERFORM 13550-PHP-PMT-FOR-OUTL
                        THRU 13550-PHP-PMT-FOR-OUTL-EXIT
                  END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (DEVICE) LINES, PAYMENT IND.   *
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      *-------------------------------------------------------------*
      * 01/01/2009 - BRACHYTHERAPY SERVICES ADDED FOR CY 2009       *
      * 11/15/2009 - BRACHYTHERAPY SERVICES (SI=U) REMOVED CY 2010  *
      *            - THERAPEUTIC RADIOPHARMS' SI NOT 'H' FOR CY2010 *
      * 08/11/2010 - NEW PASS-THROUGH DEVICE OFFSET LOGIC ADDED IN  *
      *              PARAGRAPH 10555-CALC-H-STANDARD                *
      ***************************************************************
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' H') THEN
                 IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                       OPPS-PYMT-IND (LN-SUB) = ' 6')
                   PERFORM 13555-CALC-H-STANDARD
                      THRU 13555-CALC-H-STANDARD-EXIT
                   PERFORM 13560-CALC-BENE-DEDUCT
                      THRU 13560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 13550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = G, K, R & U LINES; THE PMT. IND. *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      * 11/15/2009 - ADDED BRACHYTHERAPY SERVICES (SI=U) FOR CY2010 *
      *              THERAPEUTIC RADIOPHARMS' SI=K FOR CY 2010      *
      * 11/16/2009 - ADD LOGIC TO ADJUST PT CONTRAST AGENT HCPCS    *
      *              LINE PAYMENT BY OFFSET                         *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) =
                    ' G' OR ' K' OR ' R' OR ' U' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 13550-CALC-GJK
                         THRU 13550-CALC-GJK-EXIT

                      IF PTRADIO-LINE-FLAG = 'Y' AND
                         H-NUCMED-TOT-OFFSET > 0 THEN
                         PERFORM 13550-PTRADIO-OFFSET
                            THRU 13550-PTRADIO-OFFSET-EXIT
                      END-IF

                      IF PTCA-LINE-FLAG = 'Y' AND
                         W-PTCA-DAY-MAX > 0 AND
                         W-CAPROC-MAX > 0 THEN
                         PERFORM 13550-PTCA-OFFSET
                            THRU 13550-PTCA-OFFSET-EXIT
                      END-IF

                      PERFORM 13560-CALC-BENE-DEDUCT
                         THRU 13560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 13550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      * 11/12/2008 - BRACHYTHERAPY SOURCE'S STATUS INDICATOR = ' U' *
      *              EFFECTIVE 1/1/2009                             *
      *                                                             *
      * 11/16/2009 - REMOVED LOGIC FOR THERAPEUTIC RADIOPHARMS &    *
      *              BRACHYTHERAPY SOURCES B/C THESE ARE NOT PAID   *
      *              AT COST FOR CY 2010                            *
      *                                                             *
      * 04/11/2011 - ADDED LOGIC TO PREVENT LINES WITH PAFS 9 OR 10 *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * CALCULATE REIMBURSEMENT AND SET COINSURANCE AMOUNTS TO $0   *
      * FOR LINES WITH A PAF= 9 OR 10                               *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 9' OR '10')
                COMPUTE H-LITEM-REIM ROUNDED =
                   H-LITEM-PYMT - H-TOTAL-LN-DEDUCT
                MOVE 0 TO H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 13550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                  H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX).


      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DRUGS, DEVICES, BRACHYTHERAPY, THERAP. RADIO, & BLOOD       *
      * (SI = G AND H LINES HAVE A MIN-COIN = 0, WON'T ENTER LOGIC) *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) =
                  ' G' OR ' H' OR ' K' OR ' R' OR ' U'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       13550-CALC-STANDARD-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *                    DEVICE CREDIT PROCESSING                 *
      *                                                             *
      ***************************************************************
      *                                                             *
      * SEARCH THE DEVICE CREDIT TABLE TO SEE IF THERE IS A LINE    *
      * APC MATCH; IF SO, REDUCE THE PYMT BY THE LESSER OF THE      *
      * LINE'S PORTION OF THE DEVICE CREDIT AMOUNT OR THE LINE'S    *
      * APC CAP.                                                    *
      *                                                             *
      *    * BE SURE TO UPDATE THE TABLE REFERENCES EACH YEAR *     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/18/2013 - DEVICE CREDIT LOGIC NEW FOR CY 2014, REPLACES  *
      *              DEVICE REDUCTION LOGIC                         *
      *                                                             *
      ***************************************************************
       13550-DEVICE-CREDIT.

           SEARCH ALL DEV-CR14
              AT END
                 GO TO 13550-DEVICE-CREDIT-EXIT
              WHEN DEV-APC14 (DEV-INDX14) = OPPS-APC (LN-SUB)
                 PERFORM 13550-DEVICE-COMPUTE
                    THRU 13550-DEVICE-COMPUTE-EXIT.

       13550-DEVICE-CREDIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IF THE LINE APC IS FOUND IN THE DEVICE CREDIT TABLE,        *
      * DETERMINE HOW MUCH THE LINE DEVICE CREDIT SHOULD BE.        *
      *                                                             *
      *    * BE SURE TO UPDATE THE TABLE REFERENCES EACH YEAR *     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/18/2013 - DEVICE CREDIT LOGIC NEW FOR CY 2014, REPLACES  *
      *              DEVICE REDUCTION LOGIC                         *
      * 01/27/2014 - LOGIC REVISED TO NO LONGER SUBTRACT THE DEVICE *
      *              CREDIT BEFORE PAYMENT ADJUSTENTS ARE MADE.     *
      *              THE CREDIT IS NOW SUBTRACTED FROM THE TOTAL    *
      *              PAYMENT (ADJUSTMENTS ALREADY APPLIED) IN       *
      *              PARAGRAPH 13550-SCH-ADJ.                       *
      *                                                             *
      ***************************************************************
       13550-DEVICE-COMPUTE.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE CREDIT (FD)*
      *-------------------------------------------------------------*
           IF H-TOT-DEVCR-PYMTS > 0
              COMPUTE H-LINE-DEVCR-PYMT-RATE ROUNDED =
                      W-APC-PYMT (W-LP-INDX) / H-TOT-DEVCR-PYMTS
              COMPUTE H-LINE-DEVCR-AMT ROUNDED =
                      L-DEVICE-CREDIT * H-LINE-DEVCR-PYMT-RATE
           ELSE
              MOVE 0 TO H-LINE-DEVCR-PYMT-RATE
              MOVE 0 TO H-LINE-DEVCR-AMT
           END-IF.

      *-------------------------------------------------------------*
      * CAP THE LINE'S DEVICE CREDIT AT THE UNADJUSTED DEVICE       *
      * CREDIT CAP AMOUNT                                           *
      *-------------------------------------------------------------*
           IF DEV-CAP14 (DEV-INDX14) < H-LINE-DEVCR-AMT
              MOVE DEV-CAP14 (DEV-INDX14) TO H-LINE-DEVCR-AMT
           END-IF.

       13550-DEVICE-COMPUTE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *        FOR LINES WITH A SI OF S, V, T, P, X, R, OR U        *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA MUST BE A  *
      *   VALUE OF '   01' THRU '   99' AND THE L-PSF-PROV-TYPE     *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2009: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      * 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES (SI=R)     *
      *              ADDED TO LOGIC.  BRACHY LINES NOT PROCESSED IN *
      *              PARAGRAPH & NOW HAVE A SI = U, SI = K LOGIC    *
      *              REMOVED FROM THIS PARAGRAPH.                   *
      * 05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD    *
      *              DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.     *
      *              FIX EFFECTIVE RETROACTIVE TO 01/01/2009.       *
      * 11/17/2009 - BRACHYTHERAPY LINES NOW PROCESSED IN THIS      *
      *              PARAGRAPH FOR CY 2010 (SI=U), DO NOT RECEIVE   *
      *              WAGE ADJUSTMENT                                *
      * 05/09/2011 - REVISED LOGIC TO EXCLUDE BILL TYPE 14X FROM    *
      *              RECEIVING THE SCH ADD-ON                       *
      * 02/07/2012 - REPLACE BILL14X-FLAG WITH CONDITION NAME       *
      *              BILL-TYPE-14X                                  *
      * 01/27/2014 - WHEN APPLICABLE, SUBTRACT DEVICE CREDIT        *
      *              AMOUNT FROM LINE ITEM PAYMENT                  *
      *                                                             *
      ***************************************************************
       13550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      ***************************************************************

             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22') AND
                 (NOT BILL-TYPE-14X))
      *          (BILL14X-FLAG = 'N'))

      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      *********************  ****************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = R (BLOOD) OR U (BRACHY) LINES ARE NOT WAGE-ADJUSTED    *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U'
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.

      *-------------------------------------------------------------*
      * REDUCE PAYMENT BY DEVICE CREDIT IF APPLICABLE               *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T') AND
                 H-LINE-DEVCR-AMT > 0)
                 IF H-LITEM-PYMT >= H-LINE-DEVCR-AMT
                    COMPUTE H-LITEM-PYMT ROUNDED =
                            H-LITEM-PYMT - H-LINE-DEVCR-AMT
                 ELSE
                    MOVE 0 TO H-LITEM-PYMT
                 END-IF
             END-IF.

       13550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *         SET PARTIAL HOSPITALIZATION (PHP) "CAP" APC         *
      *             FOR USE IN THE OUTLIER CALCULATION              *
      *                  (FOR SI = P LINES ONLY)                    *
      *                                                             *
      *       ** ASK POLICY FOR THE PHP "CAP" APC ANUALLY **        *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/13/2008 - THIS PARAGRAPH IS NEW FOR CY 2009,             *
      *              CY 2009 PHP "CAP" APC = 0173                   *
      * 11/15/2010 - MODIFIED LOGIC TO ASSIGN CMHCS APC 00173 &     *
      *              HOSPITALS APC 00176                            *
      * 11/04/2011 - MODIFIED LOGIC TO STOP APPLYING APC 00176      *
      *              CAP TO PHP HOSPITAL LINES                      *
      *                                                             *
      ***************************************************************
       13550-PHP-PMT-FOR-OUTL.

      *-------------------------------------------------------------*
      *  ** FOR CMHC CLAIMS ONLY - USE APC 00173                    *
      *  LOOK-UP PHP "CAP" APC IN THE APC TABLE, STARTING AT        *
      *  THE APC'S MOST CURRENT RECORD - RETRIEVE PAYMENT RATE      *
      *-------------------------------------------------------------*
             IF (L-PSF-PROV-3456 >= '1400' AND
                 L-PSF-PROV-3456 <= '1499') OR
                (L-PSF-PROV-3456 >= '4600' AND
                 L-PSF-PROV-3456 <= '4799') OR
                (L-PSF-PROV-3456 >= '4900' AND
                 L-PSF-PROV-3456 <= '4999')
              SEARCH ALL WAA-ENTRY
                AT END
                   GO TO 13550-PHP-PMT-FOR-OUTL-EXIT

                WHEN WAA-APC (WAA-INDX) = '00173'
                   MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                   PERFORM 13550-PHP-APC-LOOKUP.

      *-------------------------------------------------------------*
      * REDUCE APC PMT RATE BY REDUCED UPDATE RATIO WHEN APPROPRIATE*
      * 11/13/2009 - NEW FOR CY 2009                                *
      *-------------------------------------------------------------*
             PERFORM 13180-REDUCE-APC-PYMT
                THRU 13180-REDUCE-APC-PYMT-EXIT.

      *-------------------------------------------------------------*
      * APPLY THE SCH ADJUSTMENT TO APC RATE WHEN APPLICABLE        *
      * CY 2009 ADJ = 7.1%                                          *
      *-------------------------------------------------------------*
             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))
                     COMPUTE H-APC-PYMT ROUNDED =
                         (H-APC-PYMT * 1.071)
             END-IF.

      *-------------------------------------------------------------*
      *  CALCULATE THE PHP "CAP" APC'S LINE PAYMENT (INCLUDES       *
      *  WAGE ADJUSTMENT AND SCH ADJUSTMENT IF APPLICABLE)          *
      *-------------------------------------------------------------*
             COMPUTE H-PHP-LITEM-PYMT-OUTL ROUNDED =
                       (((H-APC-PYMT * .60) *
                            W-WINX (W-LP-INDX)) +
                         (H-APC-PYMT * .40)) *
                       W-SRVC-UNITS (W-LP-INDX) *
                       W-DISC-RATE (W-LP-INDX).

       13550-PHP-PMT-FOR-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            LOOK-UP PHP "CAP" APC IN THE APC TABLE           *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/13/2008 - THIS PARAGRAPH IS NEW FOR CY 2009              *
      *                                                             *
      ***************************************************************
       13550-PHP-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE ZEROS TO H-APC-PYMT

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 13550-PHP-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT.

       13550-PHP-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = G, K, R, & U LINES:  *
      *   - APC PAYMENT FOR BLOOD LINES (SI = R)                    *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = G, K, OR U LINES (DRUGS,     *
      *     BIOLOGICALS, RADIOPHARMS, & BRACHYTHERAPIES)            *
      *   - SCH ADJUSTMENT APPLIED TO BLOOD & BRACHY LINES          *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      * - 11/12/2008 - FOR CY 2009, BRACHYS NOT PROCESSED IN THIS   *
      *   PARAGRAPH; BRACHY LINES ASSIGNED A NEW SI OF ' U'         *
      * - 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES HAVE A   *
      *   SI = R                                                    *
      * - 12/05/2008 - MODIFIED LOGIC TO SEND BLOOD LINES WITHOUT   *
      *   A PMT ADJ FLAG = 5 OR 6 TO THE SCH ADJUSTMENT PARAGRAPH,  *
      *   INCLUDED SI = R IN THE BLOOD IDENTIFICATION LOGIC         *
      * - 11/15/2009 - BRACHYTHERPY SERVICES (SI = U) & THERAPEUTIC *
      *   RADIOPHARMS (SI = K) SENT TO THIS PARAGRAPH FOR CY 2010,  *
      *   LOGIC ALTERED TO PROCESS SI = U (RECEIVE REGULAR APC PMT) *
      * - 11/17/2009 - SEND BRACHYTHERAPY LINES TO 10550-SCH-ADJ TO *
      *   MAKE ELIGIBLE FOR SCH ADJUSTMENT, NOT WAGE ADJUSTED       *
      *                                                             *
      ***************************************************************
       13550-CALC-GJK.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 13550-SET-BLOOD-FRACTION
                     THRU 13550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 13550-ADJ-BLOOD-COST
                     THRU 13550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 13550-SCH-ADJ
                     THRU 13550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE, BUT PAF = 5 OR 6           *
      * (BLOOD PROCESSING AND PRODUCT BILLED TOGETHER)              *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 13550-ADJ-PLATE-COST
                      THRU 13550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 13550-SCH-ADJ
                      THRU 13550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE AND PAF NOT EQUAL TO 5 OR 6 *
      * (ONLY BLOOD PRODUCT BILLED)                                 *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 12/05/2008 - 7550-SCH-ADJ PERFORM ADDED FOR BLOOD LINES     *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 13550-SCH-ADJ
                      THRU 13550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      *    CALCULATE LINE ITEM PAYMENT FOR DRUGS, BIOLOGICALS,      *
      *    BRACHYTHERAPY SERVICES, & THERAPEUTIC RADIOPHARMS        *
      *                                                             *
      ***************************************************************
                ELSE
                   IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                      COMPUTE H-LITEM-PYMT ROUNDED =
                       W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                        * W-DISC-RATE (W-LP-INDX)
                   ELSE
                      IF OPPS-SRVC-IND (LN-SUB) = ' U'
                         PERFORM 13550-SCH-ADJ
                            THRU 13550-SCH-ADJ-EXIT
                      END-IF
                   END-IF
                END-IF
             END-IF
             END-IF.

       13550-CALC-GJK-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       13550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       13550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       13550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       13550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       13550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       13550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      ADJUST THE PASS-THROUGH RADIOPHARM PAYMENT BY          *
      *      ITS PROPORTION OF THE NUCLEAR MEDICINE OFFSET          *
      *                                                             *
      *      EFFECTIVE 04/01/2009, LOGIC ADDED 02/11/2009           *
      *                                                             *
      ***************************************************************
       13550-PTRADIO-OFFSET.

      *-------------------------------------------------------------*
      * CALCULATE PROPORTION OF TOTAL OFFSET TO BE APPLIED TO LINE  *
      *-------------------------------------------------------------*
      * 12/20/2009 - ADDED LOGIC TO PREVENT DIVISION BY ZERO ERROR  *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             IF H-PTRADIO-TOT-CHRGS > 0 THEN
                COMPUTE W-PTRADIO-CHRG-RATE ROUNDED =
                        H-SUB-CHRG / H-PTRADIO-TOT-CHRGS
             ELSE
                MOVE 0 TO W-PTRADIO-CHRG-RATE
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE APPLIED TO LINE           *
      *-------------------------------------------------------------*
             COMPUTE W-PTRADIO-LINE-OFFSET ROUNDED =
                     H-NUCMED-TOT-OFFSET * W-PTRADIO-CHRG-RATE.

      *-------------------------------------------------------------*
      * SUBTRACT THE APPLICABLE OFFSET FROM THE LINE PAYMENT        *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-PYMT ROUNDED =
                     H-LITEM-PYMT - W-PTRADIO-LINE-OFFSET.

       13550-PTRADIO-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      ADJUST THE PASS-THROUGH CONTRAST AGENT PAYMENT BY      *
      *   ITS PROPORTION OF THE PT CONTRAST AGENT PROCEDURE OFFSET  *
      *                                                             *
      *      EFFECTIVE 01/01/2010, LOGIC ADDED 11/16/2009           *
      *                                                             *
      ***************************************************************
       13550-PTCA-OFFSET.

      *-------------------------------------------------------------*
      * CAPTURE LINE DATE OF SERVICE                                *
      *-------------------------------------------------------------*
             MOVE OPPS-LITEM-DOS (LN-SUB) TO W-CAPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT CONTRAST AGENT DAY TABLE FOR DATE OF SERVICE      *
      *-------------------------------------------------------------*
             SET W-PTCA-DAY-INDX TO 1.

             SEARCH W-PTCA-DAY-ENTRY

      *-------------------------------------------------------------*
      * DATE OF SERVICE NOT FOUND IN TABLE, STOP PROCESS            *
      *-------------------------------------------------------------*
                AT END
                   GO TO 13550-PTCA-OFFSET-EXIT

      *-------------------------------------------------------------*
      * DATE OF SERVICE FOUND IN TABLE, TAKE OFFSET                 *
      *-------------------------------------------------------------*
                WHEN W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX) =
                     W-CAPROC-SRVC-DATE

      *-------------------------------------------------------------*
      * CALCULATE PROPORTION OF TOTAL OFFSET TO BE APPLIED TO LINE  *
      *-------------------------------------------------------------*
      * 12/20/2009 - ADDED LOGIC TO PREVENT DIVISION BY ZERO ERROR  *
      *-------------------------------------------------------------*
                     MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                     IF W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX) > 0
                        COMPUTE W-PTCA-CHRG-RATE ROUNDED =
                                H-SUB-CHRG /
                                W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX)
                     ELSE
                        MOVE 0 TO W-PTCA-CHRG-RATE
                     END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE APPLIED TO LINE           *
      *-------------------------------------------------------------*
                     COMPUTE W-PTCA-LINE-OFFSET ROUNDED =
                         W-PTCA-DAY-TOT-OFFSET (W-PTCA-DAY-INDX) *
                         W-PTCA-CHRG-RATE

      *-------------------------------------------------------------*
      * SUBTRACT THE APPLICABLE OFFSET FROM THE LINE PAYMENT        *
      *-------------------------------------------------------------*
                     IF H-LITEM-PYMT >= W-PTCA-LINE-OFFSET
                        COMPUTE H-LITEM-PYMT ROUNDED =
                                H-LITEM-PYMT - W-PTCA-LINE-OFFSET
                     ELSE
                        MOVE 0 TO H-LITEM-PYMT
                     END-IF
             END-SEARCH.

       13550-PTCA-OFFSET-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *           CALCULATE PAYMENT FOR PAID AT COST LINES          *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 08-11-2010 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED       *
      *                                                             *
      ***************************************************************
       13555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST - "PAID AT COST"         *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).

      *-------------------------------------------------------------*
      * SEARCH THE PTDO HCPCS TABLE FOR THE CURRENT LINE HCPCS,     *
      * IF FOUND APPLY THE OFFSET                                   *
      *-------------------------------------------------------------*
              SET W-PTDO-HCPCS-INDX TO 1.
              SEARCH W-PTDO-HCPCS-ENTRY

                 AT END
                    CONTINUE

                 WHEN W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX) =
                        OPPS-HCPCS (LN-SUB) AND
                      W-PTDO-HCPCS-LNSUB (W-PTDO-HCPCS-INDX) =
                        LN-SUB
                      PERFORM 13556-CALC-PTDO-OFFSET
                         THRU 13556-CALC-PTDO-OFFSET-EXIT.

      *-------------------------------------------------------------*
      * CAPTURE PAYMENT AMOUNT                                      *
      *-------------------------------------------------------------*
             IF T-LITEM-PYMT < 0 THEN
                MOVE 0 TO H-LITEM-PYMT
             ELSE
                MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

      *-------------------------------------------------------------*
      * UPDATE PASS-THROUGH DEVICE TABLE WITH LINE ITEM PAYMENT OF  *
      * DEVICE LINE (CHARGES CONVERTED TO COST LESS APPLICABLE      *
      * OFFSET AMOUNT)                                              *
      * WHEN PTD-FLAG = 'Y', A PASS-THROUGH DEVICE IS ON THE CLAIM  *
      *-------------------------------------------------------------*
      * 11/16/2009   REMOVED LOGIC THAT EXCLUDES THERAP. RADIOS     *
      *              (THERAP. RADIOS DO NOT HAVE AN SI=H CY 2010)   *
      *-------------------------------------------------------------*
             IF PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' H'
                  PERFORM 13557-LOAD-PTD-LINE-PYMT
                     THRU 13557-LOAD-PTD-LINE-PYMT-EXIT
             END-IF.

       13555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *   REDUCE LINE ITEM PAYMENTS OF PASS-THROUGH DEVICES THAT    *
      * HAVE AN ASSOCIATED PROCEDURE ON THE CLAIM BY THE PROCEDURE  *
      *                WAGE-ADJUSTED OFFSET AMOUNT                  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ** EFFECTIVE 10/01/2010 - REVISED PT DEVICE OFFSET LOGIC    *
      *                                                             *
      ***************************************************************
       13556-CALC-PTDO-OFFSET.

      *-------------------------------------------------------------*
      * SEARCH PTDO PROCEDURE TABLE FOR THE PT DEVICE HCPCS LINE    *
      *-------------------------------------------------------------*
             SET W-PTDO-PROC-INDX TO 1.
             SEARCH W-PTDO-PROC-ENTRY

                AT END
                   GO TO 13556-CALC-PTDO-OFFSET-EXIT

      *-------------------------------------------------------------*
      * CURRENT PT DEVICE LINE'S ASSOCIATED PROCEDURE FOUND         *
      *-------------------------------------------------------------*
                WHEN W-PTDO-PROC-APC (W-PTDO-PROC-INDX) =
                       W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX) AND
                     W-PTDO-PROC-LNSUB (W-PTDO-PROC-INDX) =
                       W-PTDO-HCPCS-PROC-LNSUB (W-PTDO-HCPCS-INDX)

      *-------------------------------------------------------------*
      * DETERMINE HOW MANY PROCEDURE UNITS WILL BE ALLOCATED        *
      *-------------------------------------------------------------*
                   IF W-PTDO-PROC-UNITS (W-PTDO-PROC-INDX) <=
                      W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX)
                      MOVE W-PTDO-PROC-UNITS (W-PTDO-PROC-INDX) TO
                           W-DOPROC-UNITS
                   ELSE
                      MOVE W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX) TO
                           W-DOPROC-UNITS
                   END-IF

      *-------------------------------------------------------------*
      * DETERMINE WHAT % OF THE OFFSET WILL BE APPLIED              *
      *-------------------------------------------------------------*
                   IF W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX) > 0
                      COMPUTE W-PTDO-CHRG-RATE ROUNDED =
                           W-PTDO-HCPCS-SUB-CHRG (W-PTDO-HCPCS-INDX) /
                           W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX)
                   ELSE
                      GO TO 13556-CALC-PTDO-OFFSET-EXIT
                   END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE TAKEN                     *
      *-------------------------------------------------------------*
                   COMPUTE W-PTDO-LINE-OFFSET ROUNDED =
                           W-PTDO-CHRG-RATE *
                           W-DOPROC-UNITS *
                           W-PTDO-PROC-WA-OFFSET (W-PTDO-PROC-INDX)

      *-------------------------------------------------------------*
      * SUBTRACT THE OFFSET AMOUNT FROM THE LINE PAYMENT            *
      *-------------------------------------------------------------*
                   IF W-PTDO-LINE-OFFSET <= T-LITEM-PYMT
                      COMPUTE T-LITEM-PYMT ROUNDED =
                              T-LITEM-PYMT - W-PTDO-LINE-OFFSET
                   ELSE
                      MOVE 0 TO T-LITEM-PYMT
                   END-IF.


       13556-CALC-PTDO-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH CHARGES FOR THE      *
      *  DEVICE LINE (LINE ITEM PAYMENT LESS OFFSET CONVERTED TO    *
      *  CHARGES)                                                   *
      *  (FOR ASSOCIATED PROCEDURE OUTLIER CALCULATION)             *
      *                                                             *
      ***************************************************************
       13557-LOAD-PTD-LINE-PYMT.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR THE RECORD THAT   *
      * CORRESPONDS TO THE CURRENT SERVICE LINE                     *
      *-------------------------------------------------------------*
             SET W-PTD-INDX TO 1.
             SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS NOT        *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   GO TO 13557-LOAD-PTD-LINE-PYMT-EXIT

      *-------------------------------------------------------------*
      * IF THE LINE'S HCPCS IS IN THE TABLE, CALCULATE THE LINE'S   *
      * CHARGES AND PLACE INTO TABLE (FOR H LINES, THE PAYMENT IS   *
      * CONVERTED TO COST AND OFFSET.  HERE, THE PAYMENT IS         *
      * CONVERTED BACK INTO CHARGES BY DIVIDING IT BY THE COST TO   *
      * CHARGE RATIO.)                                              *
      *-------------------------------------------------------------*
                WHEN  W-PTD-SUB (W-PTD-INDX) = LN-SUB
                      MOVE H-LITEM-PYMT TO W-PTD-LITEM-PYMT (W-PTD-INDX)

             END-SEARCH.

       13557-LOAD-PTD-LINE-PYMT-EXIT.
            EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       13560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * LINES INELIGIBLE FOR DEDUCTIBLE SKIP DEDUCTIBLE CALCULATION *
      * EFF. 7/1/2009 - CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      * ASSIGNED A PAF = ' 4'                                       *
      * - 04/11/2011 - ADDED PAF 9 FOR SERVICES WHERE THE           *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *   (ADDED FOR PREVENTIVE SERVICES WAIVER IN CY 2011)         *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 4' OR ' 9')
                GO TO 13560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       13560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      * - 11/12/2008: FOR CY 2009, BRACHYS SI = U AND BLOOD SI = R  *
      *   BRACHY INELIGIBLE FOR OUTLIER, BLOOD ELIGIBLE FOR OUTLIER *
      *                                                             *
      * - 12/05/2008: ADDED SI = K TO LIST OF SIS INELIGIBLE FOR    *
      *   OUTLIER (BRACHYS & BLOOD NO LONGER HAVE SI = K)           *
      *                                                             *
      * - 11/17/2009: REMOVED U FROM LIST OF SIS INELIGIBLE FOR     *
      *   OUTLIER; BRACHYS NOW ELIGIBLE B/C NOT PAID AT COST CY 2010*
      *                                                             *
      * - 12/16/2009: ADDED SIS R AND U TO LOGIC THAT DISTRIBUTES   *
      *   PACKAGED CHARGES TO PAYABLE LINES. V2010.1.2              *
      *                                                             *
      * - 11/04/2011: MODIFIED LOGIC TO APPLY THE PHP CAP ONLY TO   *
      *   PHP CMHC LINES, NOT PHP HOSPITAL LINES PER POLICY'S       *
      *   INSTRUCTIONS                                              *
      *                                                             *
      ***************************************************************
       13600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * LINES WITH SERVICE INDICATORS NOT ELIGIBLE FOR AN OUTLIER   *
      * PAYMENT AND LINES PACKAGED AS PART OF DRUG ADMINISTRATION   *
      * APC PAYMENT BYPASS OUTLIER CALCULATION                      *
      * (DRUGS, DEVICES, PACKAGED SERVICES, BIOLOGICALS)            *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW THAT DISTRIBUTES PACKAGED *** *
      * *** CHARGES TO PAYABLE LINES AND IN THE SUMMING LOGIC   *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * 11/12/2008 - BRACHY (SI=U) ADDED TO LIST                    *
      * 12/05/2008 - SI K ADDED TO THE LIST                         *
      * 11/16/2009 - REMOVED PAF=2 FROM BRACHY (SI=U) CRITERIA      *
      * 11/17/2009 - REMOVE SI=U, BRACHYS ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR ' N' OR
                                          ' K') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4')
                   GO TO 13600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                             ' X' OR ' P' OR ' R' OR
                                             ' U') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                            ' X' OR ' P' OR ' R' OR
                                            ' U') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A COMPOSITE ADJ.     *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 01 - NN...) ARE ACCUMULATED BY COMPOSITE            *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME        *
      * (PAYABLE) LINE'S CHARGES.                                   *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2007 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      * 11/12/2008 - CHANGED LOGIC TO USE THE COMPOSITE ADJUSTMENT  *
      *              FLAG INSTEAD OF THE PAYMENT ADJUSTMENT FLAG    *
      *              VALUES 91 - 99 TO ID PRIME COMPOSITE LINES     *
      ***************************************************************

      *-------------------------------------------------------------*
      * COMPOSITE ADJUSTMENT FLAG > 0 INDICATES COMPOSITE APC       *
      *-------------------------------------------------------------*
           IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = '00'

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.

      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD BECAUSE PAYMENTS MAY BE  *
      *   ADJUSTED FOR PASS-THROUGH DEVICES - ADDED 02/14/2008      *
      *   NEW FOR CY 2009 - ALWAYS USE THE PHP "CAP" APC'S WAGE ADJ *
      *   PMT FOR PHP LINES (SI=P)                                  *
      *-------------------------------------------------------------*
      * 11/04/2011 - ONLY APPLY PHP "CAP" TO CMHC LINES; PER        *
      *              POLICY'S INSTRUCTIONS PHP HOSPITAL LINES ARE   *
      *              NOT CAPPED.                                    *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           IF OPPS-SRVC-IND (LN-SUB) = ' P' AND
              ( (L-PSF-PROV-3456 >= '1400' AND
                 L-PSF-PROV-3456 <= '1499') OR
                (L-PSF-PROV-3456 >= '4600' AND
                 L-PSF-PROV-3456 <= '4799') OR
                (L-PSF-PROV-3456 >= '4900' AND
                 L-PSF-PROV-3456 <= '4999') )
              MOVE H-PHP-LITEM-PYMT-OUTL TO H-LITEM-PYMT-OUTL
           ELSE
              MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL
           END-IF.


      ***************************************************************
      *   CALCULATE TOTAL CHARGES AND PAYMENTS FOR PROCEDURE LINES  *
      *             ELIGIBLE FOR PASS-THROUGH DEVICE(S)             *
      *                                                             *
      * THE CHARGES AND LINE PAYMENTS OF PASS-THROUGH DEVICE LINES  *
      * ARE ADDED TO THE CHARGES AND PAYMENTS OF ALL PROCEDURES     *
      * ELIGIBLE TO BE BILLED WITH THE PASS-THROUGH DEVICE.         *
      * (PTD-FLAG = 'Y' INDICATES THERE IS AT LEAST ONE             *
      *  PASS-THROUGH DEVICE ON THE CLAIM)                          *
      *-------------------------------------------------------------*
      * 02/12/2008 - LOGIC ADDED FOR CY 2008 QTR 2                  *
      ***************************************************************
           IF (PTD-FLAG = 'Y') AND
              (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR ' X')

      *-------------------------------------------------------------*
      * DETERMINE WHETHER THE LINE IS ELIGIBLE FOR A PT DEVICE      *
      *-------------------------------------------------------------*
              PERFORM 13670-SET-PTD-PROC-FLAG
                 THRU 13670-SET-PTD-PROC-FLAG-EXIT

      *-------------------------------------------------------------*
      * PROCEDURE IS ELIGIBLE FOR A PASS-THROUGH DEVICE             *
      *-------------------------------------------------------------*
      * 11/12/2008 - EDITED TO LOOK AT PTD-PROC-FLAG, NOT PTD-FLAG  *
      *              NO HARM DONE USING THE PTD-FLAG PREVIOUSLY     *
      *-------------------------------------------------------------*
              IF PTD-PROC-FLAG = 'Y'

      *-------------------------------------------------------------*
      * LOOP THROUGH ELIGIBLE PROCEDURE'S PASS-THROUGH DEVICE TABLE *
      * GET THE PASS-THROUGH DEVICE HCPCS(S) FOR WHICH THE          *
      * PROCEDURE IS ELIGIBLE & UPDATE PROCEDURE CHARGES & PAYMENTS *
      *-------------------------------------------------------------*
                 PERFORM 13610-PERFORM-SEARCH
                    THRU 13610-PERFORM-SEARCH-EXIT
                    VARYING W-PTD-PROC-SUB FROM 1 BY 1
                    UNTIL W-PTD-PROC-SUB > W-PTD-CNT
              END-IF
           END-IF.


      ***************************************************************
      *                                                             *
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      * -NEW FOR JANUARY 2009                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE PHP "CAP" APC'S LINE PAYMENT                        *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      * (CMHC PROVIDERS ONLY PROCESS PARTIAL HOSPITALIZATION LINES) *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT


      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE

                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 2900)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT
                  END-IF

               END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       13600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  SEARCH THE PASS-THROUGH DEVICE TABLE FOR THE PASS-THROUGH  *
      *           DEVICE(S) THE PROCEDURE IS ELIGIBLE FOR           *
      *                                                             *
      ***************************************************************
       13610-PERFORM-SEARCH.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR ALL OCCURANCES    *
      * OF THE PASS-THRU DEVICE HCPCS IN THE PASS-THRU DEVICE TABLE.*
      * THIS IS DONE FOR ALL PASS-THROUGH DEVICES THE PROCEDURE IS  *
      * ELIGIBLE FOR.                                               *
      *-------------------------------------------------------------*
           MOVE 'N' TO W-END-OF-PTD-TBL.

           IF W-PTD-PROC-HCPCS (W-PTD-PROC-SUB) NOT = '     '
              SET W-PTD-INDX TO 1
              PERFORM 13611-SEARCH-PTD-HCPCS
                 THRU 13611-SEARCH-PTD-HCPCS-EXIT
                UNTIL W-END-OF-PTD-TBL = 'Y'
           END-IF.

       13610-PERFORM-SEARCH-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE & UPDATE PROCEDURE LINE PAYMENTS   *
      *                         AND CHARGES                         *
      *                                                             *
      ***************************************************************
       13611-SEARCH-PTD-HCPCS.

           MOVE 'N' TO W-END-OF-PTD-TBL.

      *-------------------------------------------------------------*
      * SEARCH PASS-THROUGH DEVICE TABLE                            *
      *-------------------------------------------------------------*
           SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THERE ARE NO MORE OCCURANCES OF THE PASS-THROUGH DEVICE, *
      * STOP THE SEARCH AND INDICATE END OF FILE                    *
      *-------------------------------------------------------------*
                AT END
                   MOVE 'Y' TO W-END-OF-PTD-TBL
                   GO TO 13611-SEARCH-PTD-HCPCS-EXIT

      *-------------------------------------------------------------*
      * IF THE PASS-THROUGH DEVICE IS FOUND, INDICATE NOT END OF    *
      * FILE AND UPDATE THE PROCEDURE'S CHARGES AND PAYMENTS        *
      *-------------------------------------------------------------*
                WHEN  W-PTD-HCPCS (W-PTD-INDX) =
                      W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)

                      MOVE 'N' TO W-END-OF-PTD-TBL

                      PERFORM 13612-UPDATE-PTD-PROC
                         THRU 13612-UPDATE-PTD-PROC-EXIT

                      SET W-PTD-INDX UP BY 1

             END-SEARCH.

      *-------------------------------------------------------------*
      * SET UP FOR NEXT PASS-THROUGH DEVICE RECORD                  *
      *-------------------------------------------------------------*
             MOVE ZEROS TO H-PTD-UNIT-RATE
                           H-PTD-SUB-CHRG
                           H-PTD-LITEM-PYMT.

       13611-SEARCH-PTD-HCPCS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE PROCEDURE LINE'S PAYMENTS AND CHARGES WITH THE   *
      * PASS-THROUGH DEVICE'S PAYMENTS AND CHARGES (IN PROPORTION   *
      * TO THE PROCEDURE'S UNITS IF OTHER PROCEDURES ARE ELIGIBLE   *
      *            FOR THE PASS-THROUGH DEVICE AS WELL)             *
      *                                                             *
      ***************************************************************
       13612-UPDATE-PTD-PROC.

      *-------------------------------------------------------------*
      * DETERMINE PROPORTION OF CHARGES & PAYMENTS PROCEDURE LINE   *
      * WILL RECEIVE BASED ON ITS NUMBER OF UNITS                   *
      *-------------------------------------------------------------*
           IF W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX) NOT = 0
              COMPUTE H-PTD-UNIT-RATE ROUNDED =
                      OPPS-SRVC-UNITS (LN-SUB) /
                      W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX)
           ELSE
              MOVE 0 TO H-PTD-UNIT-RATE
           END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE AMOUNT OF PASS-THROUGH DEVICE CHARGES TO BE   *
      * ADDED TO THE PROCEDURE'S CHARGES IN PROPORTION TO UNITS     *
      *-------------------------------------------------------------*
           COMPUTE H-PTD-SUB-CHRG ROUNDED =
                   W-PTD-SUB-CHRG (W-PTD-INDX) *
                   H-PTD-UNIT-RATE.

      *-------------------------------------------------------------*
      * ADD PASS-THROUGH DEVICE CHARGES TO PROCEDURE LINE CHARGES   *
      *-------------------------------------------------------------*
           COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                   W-SUB-CHRG (W-LP-INDX) +
                   H-PTD-SUB-CHRG.

      *-------------------------------------------------------------*
      * CALCULATE THE AMOUNT OF PASS-THROUGH DEVICE PAYMENTS TO BE  *
      * ADDED TO THE PROCEDURE'S PAYMENTS IN PROPORTION TO UNITS    *
      *-------------------------------------------------------------*
           COMPUTE H-PTD-LITEM-PYMT ROUNDED =
                   W-PTD-LITEM-PYMT (W-PTD-INDX) *
                   H-PTD-UNIT-RATE.

      *-------------------------------------------------------------*
      * ADD PASS-THROUGH DEVICE PAYMENT TO PROCEDURE LINE PAYMENT   *
      *-------------------------------------------------------------*
           COMPUTE H-LITEM-PYMT-OUTL ROUNDED =
                   H-LITEM-PYMT-OUTL +
                   H-PTD-LITEM-PYMT.


       13612-UPDATE-PTD-PROC-EXIT.
           EXIT.
      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 13550-CALC-GJK &       *
      *      13550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES        *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       13655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9021' OR
                                    'P9056' OR
                                    'P9051' OR
                                    'P9016' OR
                                    'P9010' OR
                                    'P9038' OR
                                    'P9054' OR
                                    'P9040' OR
                                    'P9022' OR
                                    'P9058' OR
                                    'P9039' OR
                                    'P9057'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       13655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A PASS-THROUGH      *
      *  DEVICE HCPCS (FOR OUTLIER PAYMENT ADJ)                     *
      *    - IF SO, SET PTD-LINE-FLAG = 'Y'                         *
      *    - THIS FLAG IS USED IN THE PASS-THROUGH DEVICE LOGIC     *
      *      TO POPULATE THE PASS-THROUGH-DEVICE TABLE              *
      *  ** UPDATE THIS LIST EVERY QUARTER                          *
      *  (CODE NEW FOR CY2008 QTR 2; ADDED 02/11/2008)              *
      *                                                             *
      ***************************************************************
       13665-SET-PTD-LINE-FLAG.

           MOVE 'N' TO PTD-LINE-FLAG.

      ***********************************************************
      * 11/12/2008 - ALL LOGIC DISABLED B/C THERE ARE NO        *
      *              NO PASS-THROUGH DEVICES FOR CY 2009        *
      * 11/18/2009 - NO PASS-THROUGH DEVICES FOR CY 2010        *
      * 08/12/2010 - NEW PT DEVICE EFFECTIVE OCTOBER 1, 2010    *
      * 08/15/2011 - NEW PT DEVICES EFFECTIVE OCTOBER 1, 2011   *
      * 11/04/2011 - NEW PT DEVICES EFFECTIVE JANUARY 1, 2012   *
      * 11/07/2011 - UPDATED LOGIC FOR CY 2013                  *
      * 07/30/2013 - UPDATED LOGIC FOR CY 2013 + HCPC C1841     *
      ***********************************************************

      *---------------------------------------------------------*
      * ONLY CLAIMS WITH A DATE OF SERVICE ON OR AFTER          *
      * 10/01/2010 ARE ELIGIBLE                                 *
      *---------------------------------------------------------*
           IF OPPS-LITEM-DOS (LN-SUB) >= 20101001

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 10/01/2010       *
      * DEVICE HCPCS C1749 IS TERMINATED & NOT VALID IN CY 2013 *
      *---------------------------------------------------------*
      *       IF (OPPS-LITEM-DOS (LN-SUB) >= 20101001 AND
      *           OPPS-LITEM-DOS (LN-SUB) <= 20121231 AND
      *           OPPS-HCPCS (LN-SUB) = 'C1749')  OR

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 10/01/2011       *
      *---------------------------------------------------------*
              IF (OPPS-LITEM-DOS (LN-SUB) >= 20111001 AND
                  OPPS-HCPCS (LN-SUB) = ('C1830' OR
                                         'C1840') ) OR

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 01/01/2012       *
      *---------------------------------------------------------*
                 (OPPS-LITEM-DOS (LN-SUB) >= 20120101 AND
                  OPPS-HCPCS (LN-SUB) = ('C1840' OR
                                         'C1886') ) OR

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 10/01/2013       *
      *---------------------------------------------------------*
                  (OPPS-LITEM-DOS (LN-SUB) >= 20131001 AND
                  OPPS-HCPCS (LN-SUB) = 'C1841')

                 MOVE 'Y' TO PTD-LINE-FLAG
              END-IF
           END-IF.

       13665-SET-PTD-LINE-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A PROCEDURE         *
      *  ELIGIBLE FOR A PASS-THROUGH DEVICE (FOR OUTLIER PMT ADJ)   *
      *    - IF SO, SET PTD-PROC-FLAG = 'Y'                         *
      *    - THIS FLAG IS USED IN THE PASS-THROUGH DEVICE LOGIC     *
      *  ** UPDATE THIS LIST EVERY QUARTER                          *
      *  (CODE NEW FOR CY2008 QTR 2; ADDED 02/11/2008)              *
      *                                                             *
      ***************************************************************
       13670-SET-PTD-PROC-FLAG.

           MOVE 'N' TO PTD-PROC-FLAG.

      ***********************************************************
      * 11/12/2008 - ALL LOGIC DISABLED B/C THERE ARE NO        *
      *              NO PASS-THROUGH DEVICES FOR CY 2009        *
      * 11/18/2009 - NO PASS-THROUGH DEVICES FOR CY 2010        *
      * 08/12/2010 - NEW PT DEVICE EFFECTIVE OCTOBER 1, 2010    *
      * 08/15/2011 - NEW PT DEVICES EFFECTIVE OCTOBER 1, 2011   *
      * 11/04/2011 - NEW PT DEVICES EFFECTIVE JANUARY 1, 2012,  *
      *              AND ONE PAIRING TERMINATED 12/31/2011      *
      * 11/07/2012 - NEW PT PAIRINGS EFFECTIVE JANUARY 1, 2013, *
      *              AND THREE  PAIRINGS TERMINATED IN 2012     *
      *              THERE ARE THREE VALID PT DEVICES FOR 2013  *
      * 07/30/2013 - NEW PT PAIRING EFFECTIVE OCTOBER 1, 2013,  *
      *              THERE ARE FOUR VALID PT DEVICES FOR 2013   *
      ***********************************************************

      *---------------------------------------------------------*
      * ONLY CLAIMS WITH A DATE OF SERVICE ON OR AFTER          *
      * 10/01/2010 ARE ELIGIBLE                                 *
      * WHEN POLICY WENT INTO EFFECT - DO NOT CHANGE            *
      *---------------------------------------------------------*
           IF OPPS-LITEM-DOS (LN-SUB) >= 20101001

      *---------------------------------------------------------*
      *  SPECIFY NUMBER OF ENTRIES (# OF PT DEVICES FROM POLICY)*
      *---------------------------------------------------------*
              MOVE 4 TO W-PTD-CNT

      *---------------------------------------------------------*
      *  INITIALIZE PROCEDURE'S PTD HCPCS TABLE TO SPACES       *
      *---------------------------------------------------------*
              PERFORM VARYING W-PTD-PROC-SUB FROM 1 BY 1
                UNTIL W-PTD-PROC-SUB > W-PTD-CNT
                   MOVE SPACES TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-PERFORM


      ***********************************************************
      *                                                         *
      *      ** PT DEVICE MAPPINGS VALID DURING CY 2013 **      *
      *                                                         *
      ***********************************************************


      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 10/01/2011    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 1 (C1830)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20111001 AND
                 OPPS-HCPCS (LN-SUB) = ('38220' OR
                                        '38221')

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 1       TO W-PTD-PROC-SUB
                 MOVE 'C1830' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF


      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 01/01/2012    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 2 (C1840)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20120701 AND
                 OPPS-HCPCS (LN-SUB) = ('0308T')

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 2       TO W-PTD-PROC-SUB
                 MOVE 'C1840' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF


      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 01/01/2013    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 3 (C1886)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20130101 AND
                 OPPS-HCPCS (LN-SUB) = ('31660' OR
                                        '31661')

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 3       TO W-PTD-PROC-SUB
                 MOVE 'C1886' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF

      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 10/01/2013    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 4 (C1841)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20131001 AND
                 OPPS-HCPCS (LN-SUB) = '0100T'

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 4       TO W-PTD-PROC-SUB
                 MOVE 'C1841' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF

      *---------------------------------------------------------*
      * END OF PT DEVICE MAPPINGS VALID DURING CY 2012 FOR      *
      * LINES SERVICED ON OR AFTER 10/01/2010                   *
      *---------------------------------------------------------*
           END-IF.
       13670-SET-PTD-PROC-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE LINE HCPCS IS A CURRENT PASS-THROUGH *
      *                 RADIOPHARMACEUTICAL HCPCS                   *
      *                                                             *
      *    - IF SO: SET PTRADIO-LINE-FLAG = 'Y',                    *
      *             ADD 1 TO COUNT OF TOTAL PT RADIOPHARMS,         *
      *             ADD CHARGES TO CLAIM TOTAL PT RADIOPHARM CHRGES *
      *    - THIS FLAG IS USED IN PARAGRAPHS 13125-INIT &           *
      *      13550-CALC-STANDARD TO PROCESS PT RADIOPHARM LINES     *
      *                                                             *
      *  ** PASS-THROUGH RADOIOPHARM TABLE IS UPDATED QUARTERLY     *
      *  (CODE NEW FOR CY2009; ADDED 02/10/2009)                    *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      *  12/20/2011 - LOGIC REVISED TO INCLUDE TERMINATION DATE     *
      *               AS A VALID DATE OF SERVICE                    *
      *                                                             *
      ***************************************************************
       13680-SET-PTRADIO-LINE-FLAG.

           MOVE 'N' TO PTRADIO-LINE-FLAG.

           SEARCH ALL PTRH-ENTRY
            AT END
             MOVE 'N' TO PTRADIO-LINE-FLAG

            WHEN PTRH-PTRADIO-HCPCS (PTRH-INDX) = OPPS-HCPCS (LN-SUB)
             IF OPPS-LITEM-DOS (LN-SUB) >= PTRH-EFF-DATE (PTRH-INDX) AND
               (OPPS-LITEM-DOS (LN-SUB) <= PTRH-TERM-DATE (PTRH-INDX) OR
                PTRH-TERM-DATE (PTRH-INDX) = 0) THEN
                MOVE 'Y' TO PTRADIO-LINE-FLAG
             END-IF.

       13680-SET-PTRADIO-LINE-FL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE LINE HCPCS IS A CURRENT PASS-THROUGH *
      *                     CONTRAST AGENT HCPCS                    *
      *                                                             *
      *    - IF SO: SET PTCA-LINE-FLAG = 'Y',                       *
      *    - THIS FLAG IS USED IN PARAGRAPHS 13125-INIT &           *
      *      13550-CALC-STANDARD TO PROCESS PT CONTRAST AGENT LINES *
      *                                                             *
      *  ** PASS-THROUGH CONTRAST AGENT TABLE IS UPDATED QUARTERLY  *
      *  (CODE NEW FOR CY2010; ADDED 11/16/2009)                    *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      *  12/20/2011 - LOGIC REVISED TO INCLUDE TERMINATION DATE     *
      *               AS A VALID DATE OF SERVICE                    *
      *                                                             *
      ***************************************************************
       13681-SET-PTCA-LINE-FLAG.

           MOVE 'N' TO PTCA-LINE-FLAG.

           SEARCH ALL PTCH-ENTRY
            AT END
             MOVE 'N' TO PTCA-LINE-FLAG

            WHEN PTCH-PTCONTR-HCPCS (PTCH-INDX) = OPPS-HCPCS (LN-SUB)
             IF OPPS-LITEM-DOS (LN-SUB) >= PTCH-EFF-DATE (PTCH-INDX) AND
               (OPPS-LITEM-DOS (LN-SUB) <= PTCH-TERM-DATE (PTCH-INDX) OR
                PTCH-TERM-DATE (PTCH-INDX) = 0) THEN
                MOVE 'Y' TO PTCA-LINE-FLAG
             END-IF.

       13681-SET-PTCA-LINE-FL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE LINE HCPCS IS A CURRENT PASS-THROUGH *
      *                   DEVICE HCPCS (FOR OFFSET)                 *
      *                                                             *
      *    - IF SO: SET PTDO-LINE-FLAG = 'Y',                       *
      *    - THIS FLAG IS USED IN PARAGRAPHS 13125-INIT &           *
      *      13550-CALC-STANDARD TO PROCESS PT DEVICE LINES         *
      *                                                             *
      *  ** PASS-THROUGH DEVICE OFFSET TABLE IS UPDATED QUARTERLY   *
      *  (CODE NEW FOR OCT 2010; ADDED 08/02/2010)                  *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 12/20/2011 - LOGIC REVISED TO ACCOMMODATE DEVICES THAT HAVE *
      *              MULTIPLE PROCEDURE PAIRINGS WITH DIFFERENT     *
      *              EFFECTIVE AND TERMINATION DATES.  ALSO ENSURED *
      *              THE TERMINATION DATE IS AFTER OR ON THE        *
      *              DATE OF SERVICE.                               *
      *                                                             *
      ***************************************************************
       13682-SET-PTDO-LINE-FLAG.

           MOVE 'N' TO PTDO-LINE-FLAG.
           SET PTDO-INDX TO 1.

           SEARCH PTDO-ENTRY
            AT END
             MOVE 'N' TO PTDO-LINE-FLAG

      *----------------------------------------------------------------*
      * LINE HCPCS IS FOUND IN THE PT DEVICE OFFSET HISTORY TABLE AND  *
      * THE DATE OF SERVICE IS WITHIN THE EFFECTIVE & TERMINATION DATE *
      * PARAMETERS.                                                    *
      *----------------------------------------------------------------*
            WHEN PTDO-DEV-HCPCS (PTDO-INDX) = OPPS-HCPCS (LN-SUB) AND
                PTDO-EFF-DATE (PTDO-INDX) <= OPPS-LITEM-DOS (LN-SUB) AND
               (PTDO-TERM-DATE (PTDO-INDX) >= OPPS-LITEM-DOS (LN-SUB) OR
                PTDO-TERM-DATE (PTDO-INDX) = 0)
                MOVE 'Y' TO PTDO-LINE-FLAG.

       13682-SET-PTDO-LINE-FL-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *            PROCESS DRUG COINSURANCE TABLE RECORDS           *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE "DRUG" LINE COINSURANCE WHEN THE PROCEDURE      *
      *  COINSURANCE AMOUNTS PLUS THE "DRUG" COINSURANCE AMOUNT(S)  *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       13800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 13810-PROCESS-TYPE1
                   THRU 13810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 13840-PROCESS-TYPE2
                   THRU 13840-PROCESS-TYPE2-EXIT.

       13800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH "DRUG" COINSURANCE, DETERMINE THE *
      *  % OF TOTAL "DRUG" COINSURANCE THAT CAN BE PAID IN ADDITION *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE DRUG COINSURANCE CAN BE PAID *
      *  WHEN H-RATIO = 1, ALL OF THE DRUG COINSURANCE CAN BE PAID  *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       13810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * DRUGS WERE ADMINISTERED ON THE DAY                          *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & WAGE ADJUSTED COINSURANCE OF THE      *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL DRUG COIN THAT CAN BE    *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S DRUG COIN CAN BE PAID B/C THE PROCEDURE/  *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL DRUG COINSURANCE CAN BE PAID WITHIN THE     *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       13810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE "DRUG" LINE'S NATIONAL COINSURANCE AMOUNT AND   *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       13840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 DRUG COIN REC HAS SAME DATE OF SERVICE AS    *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE DRUG COIN RECORD *
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE DRUG LINE BY   *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD DRUG COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT    *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       13840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       13900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       13900-END-PRICE-RTN-EXIT.
           EXIT.







      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 14000 FOR CALENDAR YEAR 2015 PROCESSING        **
      **          SERVICE FROM DATES: 1/1/2015 - 12/31/2015           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE OCE)       *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ACCUMULATE PACKAGED MENTAL HEALTH CHARGES                  *
      *  7. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  8. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  9. CALCULATE SERVICE LINE PAYMENTS                            *
      * 10. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 11. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 12. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 13. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 14. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, COMPOSITE,    *
      *     AND MENTAL HEALTH CHARGES OF APPLICABLE PROCEDURES.  ALSO, *
      *     ADJUST LINE CHARGES AND PAYMENTS FOR PASS-THROUGH DEVICES  *
      *     FOR ELIGIBLE PROCEDURES.  ALL ADJUSTMENTS ARE DONE FOR     *
      *     OUTLIER DETERMINATION ONLY.                                *
      * 15. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 16. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR DRUG LINES;  *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE DRUG LINE'S REIMBURSEMENT                     *
      * 17. ACCUMULATE CLAIM TOTALS                                    *
      * 18. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       14000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY)   *
      *                                                               *
      *****************************************************************
              PERFORM 14100-INIT
                 THRU 14100-INIT-EXIT.

      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - PHP-APC-FLAG - PARTIAL HOSPITALIZATION CLAIM              *
      *     (APCS 00172, 00173, 00175, & 00176)                       *
      *   - APC34-FLAG - MENTAL HEALTH CLAIM                          *
      *   - PTD-FLAG - PASS-THROUGH DEVICE(S) ON CLAIM FOR OUTLIER    *
      *   - PTRADIO-CLAIM-FLAG - PASS-THROUGH RADIOPAHARM(S) ON CLAIM *
      *   - PTCA-CLAIM-FLAG - PASS-THROUGH CONTRAST AGENT ON CLAIM    *
      *     CREATE PASS-THROUGH CONTRAST AGENT DAY TABLE              *
      *   - PTDO-CLAIM-FLAG - PASS-THROUGH DEVICE ON CLAIM FOR OFFSET *
      *     CREATE PASS-THROUGH DEVICE HCPCS TABLE                    *
      *   - DEVCR-CLAIM-FLAG - DEVICE CREDIT AND LINE(S) ELIGIBLE TO  *
      *     RECEIVE DEVICE CREDIT ON CLAIM                            *
      *   - C-APC-CLAIM-FLAG - COMPREHENSIVE APC ON CLAIM - FOR       *
      *     SPECIAL BLOOD DEDUCTIBLE LINE LOGIC                       *
      *                                                               *
      *   - DISABLED CY 2009: C1820-OFFSET-FLAG - DEVICE OFFSET CLAIM *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY PASS-THROUGH CONTRAST AGENT DAY TABLE FOR CLAIM  *
      *--------------------------------------------------------*
              MOVE 0 TO W-PTCA-DAY-MAX.

      *--------------------------------------------------------*
      * EMPTY PASS-THROUGH DEVICE HCPCS TABLE FOR CLAIM        *
      *--------------------------------------------------------*
              MOVE 0 TO W-PTDO-HCPCS-MAX.

              PERFORM 14125-INIT
                 THRU 14125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.


      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CALCULATE TOTAL PACKAGED MENTAL HEALTH CHARGES,    *
      *            CREATE PASS-THROUGH DEVICE TABLE (OUTLIER), CREATE *
      *            NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH        *
      *            RADIOPHARMACEUTICAL OFFSET, CREATE CONTRAST        *
      *            AGENT PROCEDURE TABLE FOR PASS-THROUGH CONTRAST    *
      *            AGENT OFFSET & CREATE PASS-THROUGH DEVICE OFFSET   *
      *            PROCEDURE TABLE FOR PASS-THROUGH DEVICE OFFSET.    *
      *            (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY TABLES FOR NEW CLAIM                             *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX W-BLD-MAX W-CMP-MAX W-PTD-MAX
                        W-NUCMED-MAX W-CAPROC-MAX W-PTDO-PROC-MAX.

              PERFORM 14150-INIT
                 THRU 14150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      *--------------------------------------------------------*
      * CALCULATE TOTAL OFFSET AMT FOR PT RADIOPHARM LINE(S)   *
      * (# OF UNITS SUMMED LIMITED TO THE LESSER OF THE # OF   *
      *  PT RADIOPHARM HCPCS & THE # OF NUCLEAR MEDICINE UNITS)*
      *--------------------------------------------------------*
              IF W-NUCMED-MAX > 0
                 SET W-NUCMED-INDX TO 1
                 PERFORM UNTIL (W-NUCMED-INDX > W-NUCMED-MAX) OR
                               (W-NUCMED-INDX > H-PTRADIO-HCPCS-CNT)
                    COMPUTE H-NUCMED-TOT-OFFSET ROUNDED =
                            H-NUCMED-TOT-OFFSET +
                            W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX)
                    SET W-NUCMED-INDX UP BY 1
                 END-PERFORM
              END-IF.

      *--------------------------------------------------------*
      * CALCULATE TOTAL OFFSET AMT PER DAY FOR PT CONTRAST     *
      * AGENT LINE(S) (# OF UNITS SUMMED LIMITED TO THE LESSER *
      * OF THE # OF PT CONTRAST AGENT HCPCS & THE # OF PT      *
      * CONTRAST AGENT PROCEDURE APC UNITS PER DAY)            *
      *--------------------------------------------------------*
              IF W-PTCA-DAY-MAX > 0 AND W-CAPROC-MAX > 0
                 SET W-PTCA-DAY-INDX TO 1
                 PERFORM UNTIL (W-PTCA-DAY-INDX > W-PTCA-DAY-MAX)
                    PERFORM 14396-TOTAL-DAY-PTCA-OFFS
                       THRU 14396-TOTAL-DAY-PTCA-OFFS-EXIT
                    SET W-PTCA-DAY-INDX UP BY 1
                 END-PERFORM
              END-IF.

      *--------------------------------------------------------*
      * MAP PASS-THROUGH DEVICE HCPCS TO THEIR CORRESPONDING   *
      * OFFSET PROCEDURES                                      *
      *--------------------------------------------------------*
              PERFORM 14397-PTDO-MAPPINGS-1
                 THRU 14397-PTDO-MAPPINGS-1-EXIT
                 VARYING W-PTDO-HCPCS-INDX FROM 1 BY 1
                 UNTIL W-PTDO-HCPCS-INDX > W-PTDO-HCPCS-MAX.

              PERFORM 14397-PTDO-MAPPINGS-2
                 THRU 14397-PTDO-MAPPINGS-2-EXIT
                 VARYING W-PTDO-HCPCS-INDX FROM 1 BY 1
                 UNTIL W-PTDO-HCPCS-INDX > W-PTDO-HCPCS-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 4 - INITIALIZE W-DCP-MAX                               *
      *   ------                                                      *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.

      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, POPULATE PASS-THROUGH      *
      *            DEVICE TABLE WITH ELIGIBLE PROCEDURE DATA AND      *
      *            DEVICE LINE ITEM PAYMENT, AND MOVE LINE ITEM       *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 14400-CALCULATE
                 THRU 14400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, COMPOSITES, MENTAL HEALTH, AND *
      *            PASS-THROUGH DEVICES, AND CALCULATE OUTLIER        *
      *            PAYMENTS                                           *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 14600-ADJ-CHRG-OUTL
                 THRU 14600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


      *****************************************************************
      *                                                               *
      *   STEP 7 - CALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS  *
      *   ------   FOR STATUS INDICATOR G & K LINES.  THE DAILY INPA- *
      *            TIENT COINSURANCE LIMIT IS APPLIED USING THE WAGE  *
      *            ADJUSTED COINSURANCE OF EACH DAY'S MOST EXPENSIVE  *
      *            PROCEDURE OR VISIT.                                *
      *            (LOOP THROUGH THE DRUG COINSURANCE TABLE)          *
      *                                                               *
      *****************************************************************
                IF GJK-FLAG = 'Y'
                   PERFORM 14800-ADJ-STV-REIM
                      THRU 14800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                ELSE
                   NEXT SENTENCE.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 14900-END-PRICE-RTN
                 THRU 14900-END-PRICE-RTN-EXIT.

       14000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY COINSURANCE LIMIT (H-IP-LIMIT)         *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       14100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE VARIABLES                         *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 11/03/2008 - APC33-FLAG REPLACED BY PHP-APC-FLAG            *
      * 11/12/2008 - BRACHY-APC-FLAG REMOVED, NOT USED FOR CY 2009  *
      * 02/09/2009 - PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG ADDED    *
      * 11/16/2009 - RADIOPH-APC-FLAG REMOVED; PTCA-CLAIM-FLAG,     *
      *              PTCA-LINE FLAG ADDED                           *
      * 02/07/2012 - BILL14X-FLAG REMOVED                           *
      * 11/18/2013 - DEVCR-CLAIM-FLAG ADDED                         *
      *-------------------------------------------------------------*
             MOVE 'N' TO PHP-APC-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG       C1820-OFFSET-FLAG
                         PHP-HCPCS-FLAG      MH-HCPCS-FLAG
                         APC34-FLAG
                         PTD-FLAG            PTD-LINE-FLAG
                         PTD-PROC-FLAG       BLD-DEDUC-HCPCS-FLAG
                         PTRADIO-CLAIM-FLAG  PTRADIO-LINE-FLAG
                         PTCA-CLAIM-FLAG     PTCA-LINE-FLAG
                         DEVCR-CLAIM-FLAG
                         C-APC-CLAIM-FLAG
                         PKG-BLD-DED-LINE-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-DEDUCT-DUE
                          A-BLOOD-PINTS-USED
                          A-WINX
                          W-LNC-MAX
                          A-DEVICE-CREDIT-QD.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.

      *-------------------------------------------------------------*
      * INITIATILIZE WORKING STORAGE DATES - 10-23-2014             *
      *-------------------------------------------------------------*
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-BEGIN-YYYY.
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-END-YYYY.

      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 14100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 14100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 14100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION14 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
      *-------------------------------------------------------------*
      *       ADDED 10-23-2014 TO CHECK FOR VALID EFFECTIVE DATE    *
      *       SPECIAL WAGE INDEX MUST HAVE CURRENT DATE             *
      *-------------------------------------------------------------*
                   IF (L-PSF-SPEC-PYMT-IND = '1' OR '2') AND
                      (L-PSF-EFFDT >= W-CY-BEGIN-DATE AND
                       L-PSF-EFFDT <= W-CY-END-DATE)
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX
                      MOVE 1260 TO H-IP-LIMIT
                      GO TO 14100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 14100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 14100-INIT-EXIT.

             MOVE 1260 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      *           APPLY WAGE INDEX FLOOR POLICY                     *
      *           UPDATED TO REFLECT NEW FLOOR LOGIC                *
      *           10-28-2014                                        *
      *                                                             *
      * >FIRST, CONFIRM FLOOR SWITCH IS SET                         *
      *-------------------------------------------------------------*
             SET W-FLOOR-LOOKUP TO TRUE.

      *-------------------------------------------------------------*
      * >CHECK FOR EXTENDED STATE CODES AND SET TO BASE STATE FOR   *
      *  FLOOR LOOKUP.                                              *
      *-------------------------------------------------------------*
             MOVE L-PSF-PROV-ST TO W-PSF-PROV-ST.
      *     **TEXAS**
             IF W-PSF-PROV-ST = '67' OR '74'
                MOVE '45' TO W-PSF-PROV-ST.
      *     **FLORIDA**
             IF W-PSF-PROV-ST = '68' OR '69'
                MOVE '10' TO W-PSF-PROV-ST.
      *     **KANSAS**
             IF W-PSF-PROV-ST = '70'
                MOVE '17' TO W-PSF-PROV-ST.
      *     **LOUISIANA**
             IF W-PSF-PROV-ST = '71'
                MOVE '19' TO W-PSF-PROV-ST.
      *     **OHIO**
             IF W-PSF-PROV-ST = '72'
                MOVE '36' TO W-PSF-PROV-ST.
      *     **PENNSYLVANIA**
             IF W-PSF-PROV-ST = '73'
                MOVE '39' TO W-PSF-PROV-ST.
      *     **CALIFORNIA**
             IF W-PSF-PROV-ST = '55' OR '75'
                MOVE '05' TO W-PSF-PROV-ST.
      *     **IOWA**
             IF W-PSF-PROV-ST = '76'
                MOVE '16' TO W-PSF-PROV-ST.
      *     **MINNESOTA**
             IF W-PSF-PROV-ST = '77'
                MOVE '24' TO W-PSF-PROV-ST.
      *     **ILLINOIS**
             IF W-PSF-PROV-ST = '78'
                MOVE '14' TO W-PSF-PROV-ST.
      *     **MARYLAND**
             IF W-PSF-PROV-ST = '80'
                MOVE '21' TO W-PSF-PROV-ST.

      *-------------------------------------------------------------*
      * >NOW, CALL WAGE INDEX LOOKUP AND LOOK FOR THE STATE FLOOR.  *
      * >STORE PSF-CBSA IN A-CBSA (IT GETS MOVED THERE IN THE NEXT  *
      *  STEP ANYWAY). THIS FREES H-PSF-CSBA FOR THE FLOOR SEARCH   *
      * >MOVE THREE SPACES + STATE CODE TO H-PSF-CBSA               *
      * >STORE RESULT IN H-WINX.                                    *
      * >MOVE A-CBSA BACK TO H-PSF-CBSA FOR CLEANUP                 *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             STRING '   ' DELIMITED BY SIZE
                   W-PSF-PROV-ST DELIMITED BY SIZE
                   INTO H-PSF-CBSA.
             PERFORM 14200-CALC-WAGEINDX
                THRU 14200-CALC-WAGEINDX-EXIT.
             MOVE A-CBSA TO H-PSF-CBSA.

      *-------------------------------------------------------------*
      *   GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN  *
      *   BY THE PSF SPECIAL WAGE INDEX VALUE)                      *
      *                                                             *
      *   NOTE: IF PSF SPECIAL WAGE INDEX VALUE USED,               *
      *         14100-INIT-EXIT WILL BE CALLED ABOVE - THIS CODE    *
      *         WILL NEVER BE REACHED. THEREFORE CHECKING FOR A 0   *
      *         VALUE SHOULD BE UNNECESSARY.                        *
      * >SET WAGE INDEX LOOKUP FLAG (FLOOR FLAG = 'N')              *
      *-------------------------------------------------------------*
             SET W-WINX-LOOKUP TO TRUE.

      *      MOVE H-PSF-CBSA TO A-CBSA. <COMMENTED OUT FOR CY2015
      *      IF H-WINX = 0 <*
                PERFORM 14200-CALC-WAGEINDX
                   THRU 14200-CALC-WAGEINDX-EXIT.

       14100-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * *STARTING CY 2015, DO NOT HARDCODE CBSA FLOOR ASSIGNMENTS*  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  SYNC ALL OF THE FOLLOWING WITH INPATIENT.                  *
      *  SEE IPPS PRICER MAINTAINER.                                *
      *                                                             *
      * * SPECIAL NOTES *                                           *
      *   -------------                                             *
      *   1) CHANGE "'N'" (INPATIENT)                               *
      *          TO "' '" (OUTPATIENT)                              *
      *                                                             *
      *   2) CHANGE 'P-NEW-CBSA-SPEC-PAY-IND' (INPATIENT)           *
      *          TO 'L-PSF-SPEC-PYMT-IND'     (OUTPATIENT)          *
      *                                                             *
      *   3) CHANGE 'HOLD-PROV-CBSA' (INPATIENT)                    *
      *          TO 'H-PSF-CBSA'     (OUTPATIENT)                   *
      *                                                             *
      *   4) CHANGE 'P-NEW-STATE'   (INPATIENT)                     *
      *          TO 'L-PSF-PROV-ST' (OUTPATIENT)                    *
      *                                                             *
      *   5) ADD SINGLE QUOTES AROUND L-PSF-PROV-ST VALUES          *
      *                                                             *
      *   BE SURE TO MAKE THESE FIVE CHANGES EVERY JANUARY          *
      *                                                             *
      ***************************************************************

      *!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      *           COMMENTED OUT FOR CY2015                          *
      *!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      *14120-FLOOR-2014.

      *-------------------------------------------------------------*

      * HARD CODED VALUES NO LONGER USED. REMOVED 10-28-2014.       *
      *-------------------------------------------------------------*
      *
429200*       IF H-PSF-CBSA = '   07'
429300*          AND L-PSF-SPEC-PYMT-IND      = 'Y'
429400*          AND L-PSF-PROV-ST = '07'
429500*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
429600*              MOVE '   07' TO H-PSF-CBSA.
429700*
429800*       IF H-PSF-CBSA = '   36'
429900*          AND L-PSF-SPEC-PYMT-IND      = 'Y'
430000*          AND L-PSF-PROV-ST = '36'
430100*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
430200*              MOVE '   36' TO H-PSF-CBSA.
430300*
430400*       IF H-PSF-CBSA = '10900'
430500*          AND L-PSF-PROV-ST = '31'
430600*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
430700*              MOVE '   31' TO H-PSF-CBSA.
430800*
430900*       IF H-PSF-CBSA = '14484'
431000*          AND L-PSF-SPEC-PYMT-IND      = 'Y'
431100*          AND L-PSF-PROV-ST = '22'
431200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
431300*              MOVE '   22' TO H-PSF-CBSA.
431400*
431500*       IF H-PSF-CBSA = '17300'
431600*          AND L-PSF-PROV-ST = '18'
431700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
431800*              MOVE '   18' TO H-PSF-CBSA.
431900*
432000*       IF H-PSF-CBSA = '22900'
432100*          AND L-PSF-PROV-ST = '37'
432200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
432300*              MOVE '   37' TO H-PSF-CBSA.
432400*
432500*       IF H-PSF-CBSA = '25540'
432600*         AND L-PSF-SPEC-PYMT-IND      = 'Y'
432700*          AND L-PSF-PROV-ST = '07'
432800*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
432900*              MOVE '   07' TO H-PSF-CBSA.
433000*
433100*       IF H-PSF-CBSA = '25540'
433200*         AND L-PSF-SPEC-PYMT-IND      = 'Y'
433300*          AND L-PSF-PROV-ST = '22'
433400*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
433500*              MOVE '   22' TO H-PSF-CBSA.
433600*
433700*       IF H-PSF-CBSA = '26820'
433800*          AND L-PSF-SPEC-PYMT-IND      = 'Y'
433900*          AND L-PSF-PROV-ST = '53'
434000*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
434100*              MOVE '   53' TO H-PSF-CBSA.
434200*
434300*       IF H-PSF-CBSA = '27180'
434400*          AND L-PSF-SPEC-PYMT-IND      = 'Y'
434500*          AND L-PSF-PROV-ST = '25'
434600*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
434700*              MOVE '   25' TO H-PSF-CBSA.
434800*
434900*       IF H-PSF-CBSA = '28700'
435000*          AND L-PSF-PROV-ST = '44'
435100*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
435200*              MOVE '   44' TO H-PSF-CBSA.
435300*
435400*       IF H-PSF-CBSA = '28700'
435500*          AND L-PSF-PROV-ST = '49'
435600*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
435700*              MOVE '   49' TO H-PSF-CBSA.
435800*
435900*       IF H-PSF-CBSA = '35644'
436000*          AND L-PSF-SPEC-PYMT-IND      = 'Y'
436100*          AND L-PSF-PROV-ST = '07'
436200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
436300*              MOVE '   07' TO H-PSF-CBSA.
436400*
436500*       IF H-PSF-CBSA = '37620'
436600*          AND L-PSF-PROV-ST = '36'
436700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
436800*              MOVE '   36' TO H-PSF-CBSA.
436900*
437000*       IF H-PSF-CBSA = '43580'
437100*          AND L-PSF-PROV-ST = '43'
437200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
437300*              MOVE '   43' TO H-PSF-CBSA.
437400*
437500*       IF H-PSF-CBSA = '48540'
437600*          AND L-PSF-PROV-ST = '36'
437700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
437800*              MOVE '   36' TO H-PSF-CBSA.
437900*
438000*       IF H-PSF-CBSA = '48540'
438100*          AND L-PSF-PROV-ST = '51'
438200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
438300*              MOVE '   51' TO H-PSF-CBSA.
438400*
438500*       IF H-PSF-CBSA = '48864'
438600*          AND L-PSF-PROV-ST = '31'
438700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
438800*              MOVE '   31' TO H-PSF-CBSA.
438900*
439000*       IF H-PSF-CBSA = '49660'
439100*          AND L-PSF-PROV-ST = '36'
439200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
439300*              MOVE '   36' TO H-PSF-CBSA.
439400*
439500*       IF H-PSF-CBSA = '49660'
439600*          AND L-PSF-PROV-ST = '39'
439700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
439800*              MOVE '   39' TO H-PSF-CBSA.
439900*
440000*       IF H-PSF-CBSA = '19060'
440100*          AND L-PSF-PROV-ST = '21'
440200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
440300*              MOVE '   21' TO H-PSF-CBSA.
440400*
440500*       IF H-PSF-CBSA = '22020'
440600*          AND L-PSF-PROV-ST = '24'
440700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
440800*              MOVE '   24' TO H-PSF-CBSA.
440900*
441000*       IF H-PSF-CBSA = '22020'
441100*          AND L-PSF-PROV-ST = '35'
441200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
441300*              MOVE '   35' TO H-PSF-CBSA.
441400*
441500*       IF H-PSF-CBSA = '24220'
441600*          AND L-PSF-PROV-ST = '24'
441700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
441800*              MOVE '   24' TO H-PSF-CBSA.
441900*
442000*       IF H-PSF-CBSA = '24220'
442100*          AND L-PSF-PROV-ST = '35'
442200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
442300*              MOVE '   35' TO H-PSF-CBSA.
442400*
442500*       IF H-PSF-CBSA = '30300'
442600*          AND L-PSF-PROV-ST = '50'
442700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
442800*              MOVE '   50' TO H-PSF-CBSA.
442900*
443000*       IF H-PSF-CBSA = '39300'
443100*          AND L-PSF-PROV-ST = '22'
443200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
443300*              MOVE '   22' TO H-PSF-CBSA.
443400*
443500*       IF H-PSF-CBSA = '39300'
443600*          AND L-PSF-PROV-ST = '41'
443700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
443800*              MOVE '   41' TO H-PSF-CBSA.
443900*
444000*       IF H-PSF-CBSA = '44600'
444100*          AND L-PSF-PROV-ST = '36'
444200*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
444300*              MOVE '   36' TO H-PSF-CBSA.
444400*
444500*       IF H-PSF-CBSA = '45500'
444600*          AND L-PSF-PROV-ST = '45'
444700*              MOVE ' ' TO L-PSF-SPEC-PYMT-IND
444800*              MOVE '   45' TO H-PSF-CBSA.


      *14120-FLOOR-2014-EXIT.
      *    EXIT.



      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND AN APC / HCPCS      *
      *                                                             *
      *  - SET FLAG IF APC = 0172/0173/0175/0176 (PARTIAL HOSP.)    *
      *  - SET FLAG IF APC = 0034 (FOR MENTAL HEALTH CHARGES)       *
      *    (NEW FOR CY 2008 - ADDED 11/28/2007)                     *
      *  - SET FLAG IF PASS-THROUGH DEVICE(S) ON CLAIM: FOR OUTLIER *
      *    (NEW FOR CY 2008 - ADDED 02/11/2008)                     *
      *  - SET FLAG IF PASS-THROUGH RADIOPHARMS(S) ON CLAIM         *
      *    (NEW FOR APRIL CY 2009 - ADDED 02/10/2009)               *
      *  - SET FLAG IF PASS-THROUGH CONTRAST AGENT(S) ON CLAIM      *
      *    (NEW FOR JANUARY CY 2010 - ADDED 11/15/2009)             *
      *  - SET FLAG IF PASS-THROUGH DEVICE(S) ON CLAIM: FOR OFFSET  *
      *    (NEW FOR OCTOBER CY 2010 - ADDED 08/02/2010)             *
      *  - SET FLAG IF CLAIM IS ELIGIBLE FOR DEVICE CREDIT          *
      *    (NEW FOR JANUARY CY 2014)                                *
      *  - SET FLAG IF CLAIM HAS A COMPREHENSIVE APC (C-APC) LINE   *
      *    (NEW FOR JULY 2016)                                      *
      *                                                             *
      *  - DISABLED: SET FLAG IF HCPCS = C1820 (FOR DEVICE OFFSETS) *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION HCPCS FROM     *
      *              0033 TO 0172 & 0173 FOR CY 2009                *
      *                                                             *
      * 11/12/2008 - HCPCS C1820 EXPIRED FROM PASS-THROUGH STATUS   *
      *              DECEMBER 2007, OFFSET FLAG LOGIC DISABLED      *
      *                                                             *
      * 08/02/2010 - ADDED LOGIC TO SET PASS-THOUGH DEVICE FLAG FOR *
      *              DEVICE OFFSETS AND POPULATE THE CORRESPONDING  *
      *              TABLE                                          *
      *                                                             *
      * 11/15/2010 - ADDED APCS 0175 & 0176 TO LIST OF PHP APCS     *
      *                                                             *
      * 11/18/2013 - ADDED LOGIC TO SET DEVICE CREDIT CLAIM FLAG    *
      *                                                             *
      * 05/09/2016 - ADDED LOGIC TO SET COMPREHENSIVE APC CLAIM FLAG*
      *                                                             *
      ***************************************************************
       14125-INIT.

      ***************************************************************
      *  OVERRIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      ***************************************************************
             IF OPPS-APC (LN-SUB) = '0339'
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A PHP APC (PARTIAL HOSP)*
      *-------------------------------------------------------------*
             IF OPPS-APC (LN-SUB) = '0172' OR
                OPPS-APC (LN-SUB) = '0173' OR
                OPPS-APC (LN-SUB) = '0175' OR
                OPPS-APC (LN-SUB) = '0176'
                MOVE 'Y' TO PHP-APC-FLAG.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS APC 0034                *
      *-------------------------------------------------------------*
             IF OPPS-APC (LN-SUB) = '0034'
                MOVE 'Y' TO APC34-FLAG.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST ONE LINE IS A PASS-THROUGH DEVICE  *
      * (FOR OUTLIER PAYMENT CALCULATION)                           *
      *-------------------------------------------------------------*
             PERFORM 14665-SET-PTD-LINE-FLAG
                THRU 14665-SET-PTD-LINE-FLAG-EXIT.

             IF PTD-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTD-FLAG
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE IS PASS-THROUGH RADIOPHARM  *
      * AND ACCUMULATE TOTAL PT RADIOPHARM LINES & CHARGES          *
      *-------------------------------------------------------------*
             PERFORM 14680-SET-PTRADIO-LINE-FLAG
                THRU 14680-SET-PTRADIO-LINE-FL-EXIT.

             IF PTRADIO-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTRADIO-CLAIM-FLAG
                ADD 1 TO H-PTRADIO-HCPCS-CNT
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-PTRADIO-TOT-CHRGS ROUNDED =
                        H-PTRADIO-TOT-CHRGS + H-SUB-CHRG
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE IS A PASS-THROUGH CONTRAST  *
      * AGENT AND ACCUMULATE TOTAL PT CONTRAST AGENT LINES &        *
      * CHARGES, SUM BY LINE ITEM DATE OF SERVICE, & CREATE A       *
      * RECORD FOR EACH DAY IN THE PASS-THROUGH CONTRAST AGENT      *
      * DAY TABLE                                                   *
      *-------------------------------------------------------------*
             PERFORM 14681-SET-PTCA-LINE-FLAG
                THRU 14681-SET-PTCA-LINE-FL-EXIT.

             IF PTCA-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTCA-CLAIM-FLAG
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                PERFORM 14130-LOAD-PTCA-DAY-TABLE
                   THRU 14130-LOAD-PTCA-DAY-TABLE-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE IS A PASS-THROUGH DEVICE    *
      * ON THE CLAIM AND CREATE A RECORD FOR THE PT DEVICE HCPCS    *
      * LINE IN THE PT DEVICE HCPCS TABLE                           *
      *-------------------------------------------------------------*
             PERFORM 14682-SET-PTDO-LINE-FLAG
                THRU 14682-SET-PTDO-LINE-FL-EXIT.

             IF PTDO-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTDO-CLAIM-FLAG
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS
                PERFORM 14132-LOAD-PTDO-HCPCS-TBL
                   THRU 14132-LOAD-PTDO-HCPCS-TBL-EXIT
             END-IF.
      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A DEVICE CREDIT SHOULD BE APPLIED           *
      *-------------------------------------------------------------*
             IF L-DEVICE-CREDIT > 0
                SEARCH ALL DEV-CR15
                    AT END
                       CONTINUE
                    WHEN DEV-APC15 (DEV-INDX15) = OPPS-APC (LN-SUB)
                       MOVE 'Y' TO DEVCR-CLAIM-FLAG
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A COMPREHENSIVE APC     *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = 'J1'
                MOVE 'Y' TO C-APC-CLAIM-FLAG
             END-IF.


       14125-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE PASS-THROUGH CONTRAST AGENT HCPCS COUNT AND     *
      *  CHARGES FOR EACH DAY WITH A PASS-THROUGH CONTRAST AGENT    *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY LINE ITEM DATE OF SERVICE (LIDOS) - *
      *    EARLIEST TO LATEST DATE                                  *
      *                                                             *
      *  EACH PT CONTRAST AGENT HCPCS LINE'S CHARGES ARE ADDED TO   *
      *  THE TOTAL FOR ITS LIDOS.  THESE CHARGES ARE LATER USED     *
      *  TO DETERMINE THE PROPORTION OF THE DAY'S TOTAL CONTRAST    *
      *  PROCEDURE OFFSET THAT SHOULD BE SUBTRACTED FROM A GIVEN PT *
      *  CONTRAST AGENT HCPCS'S LINE PAYMENT.                       *
      *                                                             *
      *  11/16/2009 - LOGIC ADDED FOR CY 2010                       *
      *                                                             *
      ***************************************************************
       14130-LOAD-PTCA-DAY-TABLE.

      *-------------------------------------------------------------*
      * GET THE LINE'S SERVICE DATE & CHARGES FOR TABLE SEARCH      *
      *-------------------------------------------------------------*
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-PTCA-LIDOS.
             MOVE OPPS-SUB-CHRG (LN-SUB)  TO H-SUB-CHRG.

      *-------------------------------------------------------------*
      * ADD OR UPDATE CONTRAST AGENT DAY ENTRY FOR THE LIDOS        *
      *-------------------------------------------------------------*
                PERFORM 14130-SEARCH-PTCA-LIDOS
                   THRU 14130-SEARCH-PTCA-LIDOS-EXIT.

       14130-LOAD-PTCA-DAY-TABLE-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW PT CONTRAST AGENT DAY TABLE RECORD  *
      * SHOULD BE ADDED OR IF AN EXISITING RECORD MUST BE UPDATED   *
      *                                                             *
      ***************************************************************
       14130-SEARCH-PTCA-LIDOS.

      *-------------------------------------------------------------*
      * SEARCH PT CONTRAST AGENT DAY TABLE STARTING AT ENTRY #1     *
      *-------------------------------------------------------------*
             SET W-PTCA-DAY-INDX TO 1.
             SEARCH W-PTCA-DAY-ENTRY VARYING W-PTCA-DAY-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S LIDOS IS NOT ALREADY IN THE TABLE,    *
      * ADD IT                                                      *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 14130-ADD-ENTRY
                      THRU 14130-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S LIDOS IS ALREADY IN THE TABLE,        *
      * UPDATE THE ENTRY                                            *
      *-------------------------------------------------------------*
                WHEN W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX) = H-PTCA-LIDOS
                   PERFORM 14130-UPDATE-ENTRY
                      THRU 14130-UPDATE-ENTRY-EXIT.

       14130-SEARCH-PTCA-LIDOS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW PT CONTRAST AGENT DAY RECORD IN THE CORRECT  *
      * POSITION (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE *
      *                                                             *
      ***************************************************************
       14130-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTCA-DAY-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-PTCA-DAY-INDX TO W-PTCA-DAY-MAX.
             INITIALIZE W-PTCA-DAY-ENTRY (W-PTCA-DAY-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW PT CONTRAST AGENT DAY ENTRY FOR THE *
      * CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE TABLE       *
      * ACCORDING TO ITS LIDOS - EARLIEST TO LATEST LIDOS           *
      *-------------------------------------------------------------*
             PERFORM 14130-STAGE-PTCA-DAY-ENTRY
                THRU 14130-STAGE-PTCA-DAY-ENTRY-EXT
                  UNTIL W-PTCA-DAY-INDX = 1 OR
                     H-PTCA-LIDOS NOT <
                       W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-PTCA-LIDOS TO W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX).
             MOVE 1 TO W-PTCA-DAY-HCPCS-CNT (W-PTCA-DAY-INDX).
             MOVE H-SUB-CHRG TO W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX).

       14130-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING PT CONTRAST AGENT DAY RECORD WITH THE   *
      * SAME LIDOS AS THE CURRENT SERVICE LINE                      *
      *                                                             *
      ***************************************************************
       14130-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE LIDOS'S TOTAL SUBMITTED CHARGES & HCPCS COUNT*
      *-------------------------------------------------------------*
             ADD 1 TO W-PTCA-DAY-HCPCS-CNT (W-PTCA-DAY-INDX).
             ADD H-SUB-CHRG TO W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX).

       14130-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING PT CONTRAST AGENT DAY RECORD WITH A LATER *
      * LIDOS DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR *
      * THE NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.   *
      *                                                             *
      ***************************************************************
       14130-STAGE-PTCA-DAY-ENTRY.

             MOVE W-PTCA-DAY-ENTRY (W-PTCA-DAY-INDX - 1) TO
                  W-PTCA-DAY-ENTRY (W-PTCA-DAY-INDX).
             SET W-PTCA-DAY-INDX DOWN BY 1.

       14130-STAGE-PTCA-DAY-ENTRY-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE PASS-THROUGH DEVICE HCPCS TABLE WITH PASS-THROUGH *
      *  DEVICE LINE INFORMATION                                    *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY SUBMITTED CHARGE                    *
      *    HIGHEST TO LOWEST,                                       *
      *        THEN BY LINE UNITS                                   *
      *          HIGHEST TO LOWEST                                  *
      *                                                             *
      *  THESE RECORDS ARE LATER USED TO DETERMINE THE PASS-THROUGH *
      *  DEVICE OFFSET AMOUNT IF APPLICABLE.                        *
      *                                                             *
      *  08/02/2010 - LOGIC ADDED FOR OCT 2010                      *
      *                                                             *
      ***************************************************************
       14132-LOAD-PTDO-HCPCS-TBL.

      *-------------------------------------------------------------*
      * POPULATE VARIABLES FOR TABLE SORTING                        *
      *-------------------------------------------------------------*
             MOVE H-SUB-CHRG   TO H-PTDO-CHRG.
             MOVE H-SRVC-UNITS TO H-PTDO-UNITS.


      *-------------------------------------------------------------*
      * ADD THE CURRENT PASS-THROUGH DEVICE HCPCS LINE TO TABLE     *
      *-------------------------------------------------------------*
             PERFORM 14132-ADD-ENTRY
                THRU 14132-ADD-ENTRY-EXIT.

       14132-LOAD-PTDO-HCPCS-TBL-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW PT DEVICE HCPCS RECORD IN THE CORRECT        *
      * POSITION (HIGHEST TO LOWEST SUBMITTED CHARGE & THEN HIGHEST *
      * TO LOWEST LINE UNITS)                                       *
      *                                                             *
      ***************************************************************
       14132-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTDO-HCPCS-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-PTDO-HCPCS-INDX TO W-PTDO-HCPCS-MAX.
             INITIALIZE W-PTDO-HCPCS-ENTRY (W-PTDO-HCPCS-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW PT DEVICE HCPCS ENTRY FOR THE       *
      * CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE TABLE       *
      * ACCORDING TO ITS SUBMITTED CHARGES & LINE UNITS (BOTH       *
      * HIGHEST TO LOWEST)                                          *
      *-------------------------------------------------------------*
             PERFORM 14132-STAGE-PTDO-HCPCS-ENTRY
                THRU 14132-STAGE-PTDO-HCPCS-ENTRY-X
                  UNTIL W-PTDO-HCPCS-INDX = 1 OR
                     H-PTDO-CHRGUNIT NOT >
                       W-PTDO-HCPCS-CHRGUNIT (W-PTDO-HCPCS-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE OPPS-HCPCS (LN-SUB) TO
                  W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX).
             MOVE LN-SUB TO
                  W-PTDO-HCPCS-LNSUB (W-PTDO-HCPCS-INDX).
             MOVE H-PTDO-CHRG TO
                  W-PTDO-HCPCS-SUB-CHRG (W-PTDO-HCPCS-INDX).
             MOVE H-PTDO-UNITS TO
                  W-PTDO-HCPCS-UNITS (W-PTDO-HCPCS-INDX).
             MOVE 0 TO W-PTDO-HCPCS-PROC-CNT (W-PTDO-HCPCS-INDX).
             MOVE SPACES TO W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX).
             MOVE 0 TO W-PTDO-HCPCS-PROC-LNSUB (W-PTDO-HCPCS-INDX).


       14132-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING PT CONTRAST AGENT DAY RECORD WITH A LATER *
      * LIDOS DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR *
      * THE NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.   *
      *                                                             *
      ***************************************************************
       14132-STAGE-PTDO-HCPCS-ENTRY.

             MOVE W-PTDO-HCPCS-ENTRY (W-PTDO-HCPCS-INDX - 1) TO
                  W-PTDO-HCPCS-ENTRY (W-PTDO-HCPCS-INDX).
             SET W-PTDO-HCPCS-INDX DOWN BY 1.

       14132-STAGE-PTDO-HCPCS-ENTRY-X.
             EXIT.


      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES, *
      *  AND CALCULATE TOTAL PACKAGED MENTAL HEALTH CHARGES.        *
      *  CREATE PASS-THROUGH CONTRAST AGENT PROC TABLE (NEW CY2010) *
      *  CREATE PASS-THROUGH DEVICE PROC TABLE (NEW OCT 2010)       *
      *                                                             *
      *  ** UPDATE PARTIAL HOSPITALIZATION (PHP) & MENTAL HEALTH    *
      *     (MH) TABLE REFERENCES EVERY JANUARY                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (NOT A PARTIAL HOSPITALIZATION OR       *
      *                      MENTAL HEALTH HCPCS))                  *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (PARTIAL HOSP. APC IS NOT ON THE CLAIM   *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  PARTIAL HOSPITALIZATION HCPCS)      *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       14150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).

      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 14250-CALC-DISCOUNT
                THRU 14250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 14150-INIT-EXIT.

      ***************************************************************
      *  CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH         *
      *  RADIOPHARM OFFSET WHEN PASS-THROUGH RADIOPHARM(S) ON CLAIM *
      *  EFFECTIVE APRIL 2009                                       *
      ***************************************************************
             IF PTRADIO-CLAIM-FLAG = 'Y'
                PERFORM 14165-PROCESS-NUCLEAR-MED
                   THRU 14165-PROCESS-NUCLEAR-MED-EXIT.


      ***************************************************************
      *  CREATE CONTRAST AGENT PROCEDURE TABLE FOR PASS-THROUGH     *
      *  CONTRAST AGENT OFFSET WHEN PT CONTRAST AGENT(S) ON CLAIM   *
      *  EFFECTIVE JANUARY 2010                                     *
      ***************************************************************
             IF PTCA-CLAIM-FLAG = 'Y'
                PERFORM 14168-PROCESS-PTCA-PROC
                   THRU 14168-PROCESS-PTCA-PROC-EXIT.


      ***************************************************************
      *  CREATE PASS-THROUGH DEVICE PROCEDURE TABLE FOR PASS-       *
      *  THROUGH DEVICE OFFSET WHEN PT DEVICE(S) ON CLAIM           *
      *  EFFECTIVE OCTOBER 2010                                     *
      ***************************************************************
             IF PTDO-CLAIM-FLAG = 'Y'
                PERFORM 14169-PROCESS-PTDO-PROC
                   THRU 14169-PROCESS-PTDO-PROC-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      *-------------------------------------------------------------*
             MOVE 'N' TO PHP-HCPCS-FLAG  MH-HCPCS-FLAG
                         PKG-BLD-DED-LINE-FLAG.

      ***************************************************************
      *  SEARCH PARTIAL HOSPITALIZATION (PHP) TABLE FOR LINE HCPCS  *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      *  11/15/2010 - FOR CY 2011, USE CY 2010 TABLE                *
      *  11/09/2012 - FOR CY 2013, USE CY 2013 TABLE                *
      *  11/25/2013 - FOR CY 2014, USE CY 2014 TABLE                *
      *  11/10/2014 - FOR CY 2015, USE CY 2014 TABLE                *
      ***************************************************************
             SEARCH ALL PHP-ENTRY14
                AT END
                   MOVE 'N' TO PHP-HCPCS-FLAG
                WHEN PHP-HCPCS14 (PHP-INDX14) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO PHP-HCPCS-FLAG.


      ***************************************************************
      *  SEARCH MENTAL HEALTH (MH) TABLE FOR LINE HCPCS             *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      *  11/15/2010 - FOR CY 2011, USE CY 2010 TABLE                *
      *  11/04/2011 - FOR CY 2012, USE CY 2012 TABLE                *
      *  11/09/2012 - FOR CY 2013, USE CY 2013 TABLE                *
      *  11/25/2013 - FOR CY 2014, USE CY 2014 TABLE                *
      *  11/10/2014 - FOR CY 2015, USE CY 2014 TABLE                *
      ***************************************************************
             SEARCH ALL MH-ENTRY14
                AT END
                   MOVE 'N' TO MH-HCPCS-FLAG
                WHEN MH-HCPCS14 (MH-INDX14) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO MH-HCPCS-FLAG.


      ***************************************************************
      *   POPULATE PASS-THROUGH DEVICE TABLE W/ PASS-THROUGH        *
      *   DEVICE LINE DATA (FOR OUTLIER PAYMENT ADJUSTMENT)         *
      *-------------------------------------------------------------*
      *   11/16/2009 - RADIOPH-APC-FLAG CHECK REMOVED B/C NO THX    *
      *                RADIOPHARMS HAVE SI=H FOR CY 2010            *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 AND
                PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' H'

                  PERFORM 14665-SET-PTD-LINE-FLAG
                     THRU 14665-SET-PTD-LINE-FLAG-EXIT

                  IF PTD-LINE-FLAG = 'Y'
                     MOVE OPPS-HCPCS (LN-SUB) TO W-PTD-LINE-HCPCS
                     PERFORM 14390-PASS-THRU-DEVICES
                        THRU 14390-PASS-THRU-DEVICES-EXIT
                  END-IF

             END-IF.


      ***************************************************************
      *   IDENTIFY LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE ON       *
      *   A CLAIM WITH A COMPREHENSIVE APC; TREAT AS PACKAGED LINE  *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      ***************************************************************
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             END-IF.



      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR ' L' OR
                ' N' OR ' P' OR ' R' OR ' S' OR ' T' OR ' U' OR
                ' V' OR ' X' OR ' W' OR ' Y' OR ' Z' OR ' M' OR 'J1')
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 14150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 14150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF ( OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR

      *--------------------------------------------------------*
      *   LINE IS DENIED OR REJECTED AND HAS A PHP OR MH HCPCS *
      *--------------------------------------------------------*
                        OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND

                            ( PHP-HCPCS-FLAG = 'Y' OR
                              MH-HCPCS-FLAG  = 'Y' ) ) OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                      ( OPPS-LITEM-ACT-FLAG (LN-SUB) = '1' )



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      * 11/03/2008 - REMOVED PAFS 91 - 99 FOR COMPOSITES FOR CY 2009*
      * 04/11/2011 - ADDED ' 9' & '10' AS VALID PAFS FOR CY 2011    *
      * 12/18/2014 - ADDED '11' FOR CY 2015                         *
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8' OR ' 9' OR '10' OR '11'


      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *                                                             *
      *   ** SITE OF SERVICE FLAG = PAYMENT METHOD FLAG IN OCE **   *
      *                                                             *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', PHP APC IS ON THE CURRENT LINE       *
      *-------------------------------------------------------------*
      * 11/06/2007 - CHANGED PHP HEALTH CODES LISTED FROM           *
      *              APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008   *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION APC FROM       *
      *              0033 TO 0172 & 0173 FOR CY 2009, FLAG CHANGED  *
      *              FROM APC33-FLAG TO PHP-APC-FLAG                *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID & PHP APC ON CLAIM - CHECK FURTHER  *
      *-------------------------------------------------------------*
                            ( (PHP-APC-FLAG = 'Y') AND

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, PHP APC ON CLAIM, & LINE APC IS PHP*
      *-------------------------------------------------------------*
                                ( (OPPS-SRVC-IND (LN-SUB) = ' P') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, PHP APC ON CLAIM, & LINE PHP HCPCS *
      *-------------------------------------------------------------*
                                  (PHP-HCPCS-FLAG = 'Y') ) )



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE ALL PACKAGED COMPOSITE LINES                      *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *   11/12/2008 - CHANGED LOGIC THAT EXCLUDES ALL COMPOSITE    *
      *                LINES & MENTAL HEALTH PKG LINES TO USE THE   *
      *                COMPOSITE ADJUSTMENT FLAG INSTEAD OF PAYMENT *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *   05/09/2016 - ADDED LOGIC TO ENSURE BLOOD DEDUCTIBLE LINES *
      *                ON CLAIMS WITH A COMPREHENSIVE APC ARE       *
      *                INCLUDED                                     *
      *-------------------------------------------------------------*
                IF ( (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                     (OPPS-COMP-ADJ-FLAG (LN-SUB) = '00') ) OR
                   PKG-BLD-DED-LINE
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED REVENUE CODE 39X BLOOD LINE CHARGES   *
      *   (BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC)      *
      *   WHEN BILLED ON CLAIM WITH A COMPREHENSIVE APC TO          *
      *   DETERMINE THE PORTION OF THE BLOOD APC PAYMENT TO BE      *
      *   DISTRIBUTED TO THE BLOOD PRODUCT (PAF = 5) LINE FOR THE   *
      *   BLOOD DEDUCTIBLE CALCULATION                              *
      *-------------------------------------------------------------*
      *   05/16/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' N' AND
               (OPPS-LITEM-RVCD (LN-SUB) = '0390' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0392' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0399')
                  COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB) +
                                          H-TOT-38X-39X
             END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME (PACKAGED) COMPOSITE APC CHARGES     *
      *   FOR EACH COMPOSITE APC BY THE COMPOSITE ADJUSTMENT FLAG   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2007 - LOGIC REVISED FOR CY 2009 TO IDENTIFY ALL    *
      *                COMPOSITE LINES USING THE COMPOSITE          *
      *                ADJUSTMENT FLAG INSTEAD OF PAYMENT           *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *                (INCLUDES PROCESSING FOR MENTAL HEALTH       *
      *                 COMPOSITES)                                 *
      *-------------------------------------------------------------*
                IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "00" AND
                   OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "  " AND
                   OPPS-SRVC-IND (LN-SUB) = ' N'
                      PERFORM 14170-COMPOSITES
                         THRU 14170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   SET RETURN CODE WHEN PACKAGED LINE OR LINE APC = 0000     *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 14150-INIT-EXIT
                END-IF


      ***************************************************************
      *   APPLY STEREOTACTIC RADIOSURGERY (SRS) PAYMENT CAP POLICY: *
      *   WHEN APPLICABLE, CHANGE SRS HCPCS 77371'S APC ASSIGNMENT  *
      *   TO '00067' TO CAP PAYMENT AT APC 00067'S RATE             *
      *-------------------------------------------------------------*
      *   02/08/2013 - LOGIC ADDED FOR APRIL 2013 RELEASE           *
      ***************************************************************
                IF OPPS-LITEM-DOS (LN-SUB) >= 20130401 AND
                   OPPS-HCPCS (LN-SUB) = '77371'
                      PERFORM 14176-APPLY-SRS-CAP
                         THRU 14176-APPLY-SRS-CAP-EXIT
                END-IF


      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 14150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 14175-APC-LOOKUP

      *-------------------------------------------------------------*
      *   REDUCE APC PMT BY REDUCED UPDATE RATIO WHEN APPROPRIATE   *
      *   11/13/2009 - NEW FOR CY 2009 (QUALITY)                    *
      *-------------------------------------------------------------*
                      PERFORM 14180-REDUCE-APC-PYMT
                         THRU 14180-REDUCE-APC-PYMT-EXIT



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 14150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 14150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 14150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 14150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 14150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 14150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF LINES ELIGIBLE FOR DEVICE CREDIT *
      * WHEN DEVICE CREDIT IS > $0 AND LINE APC IS A DEVICE         *
      * DEPENDENT APC LISTED IN DEVICE CREDIT CAP TABLE             *
      *                                                             *
      * UPDATED FOR CY2015 - 11/10/2014                             *
      ***************************************************************
             IF DEVCR-CLAIM-FLAG = 'Y'
                SEARCH ALL DEV-CR15
                    AT END
                       CONTINUE
                    WHEN DEV-APC15 (DEV-INDX15) = OPPS-APC (LN-SUB)
                       COMPUTE H-TOT-DEVCR-PYMTS =
                               H-TOT-DEVCR-PYMTS +
                               H-APC-PYMT.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                PERFORM 14300-COIN-DEDUCT
                   THRU 14300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2009.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                SET W15BD-INDX TO 1
                SEARCH W15BD-ENTRY VARYING W15BD-INDX
                   AT END
                      GO TO 14150-INIT-EXIT
                   WHEN W-2015-BLOOD-HCPCS (W15BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-2015-BLOOD-RANK (W15BD-INDX) TO H-BLOOD-RANK
                     MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                     PERFORM 14375-BLOOD-DEDUCT
                        THRU 14375-BLOOD-DEDUCT-EXIT
                    END-IF.

       14150-INIT-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *     PROCESS LINES WITH A NUCLEAR MEDICINE APC FOR THE       *
      *              PASS-THROUGH RADIOPHARM OFFSET                 *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE PTROFFST FOR LINE APC & LINE YEAR       *
      *      - IF FOUND, ADD A RECORD TO TABLE W-NUCMED-APC-TBL     *
      *        FOR EVERY UNIT.                                      *
      *                                                             *
      *  02/10/2009 - LOGIC ADDED EFFECTIVE STARTING APRIL 2009     *
      *                                                             *
      ***************************************************************
       14165-PROCESS-NUCLEAR-MED.

      *-------------------------------------------------------------*
      * HOLD THE LINE'S APC, UNITS, & SERVICE FROM DATE             *
      *-------------------------------------------------------------*
             MOVE OPPS-GRP (LN-SUB)        TO W-NUCMED-LINE-APC.
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO W-NUCMED-UNIT-CNT.
             MOVE OPPS-LITEM-DOS (LN-SUB)  TO W-LINE-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT RADIOPHARM OFFSET TABLE FOR THE APC & YEAR        *
      *-------------------------------------------------------------*
             SET PTRO-INDX TO 1.
             SEARCH PTRO-ENTRY
              AT END
                 GO TO 14165-PROCESS-NUCLEAR-MED-EXIT

      *-------------------------------------------------------------*
      * WHEN APC & YEAR FOUND, WAGE ADJUST OFFSET & ADD NEW RECORD  *
      * TO NUCLEAR MEDICINE TABLE FOR EVERY UNIT                    *
      *-------------------------------------------------------------*
              WHEN PTRO-NUCMED-APC (PTRO-INDX) = W-NUCMED-LINE-APC AND
                   PTRO-EFF-YEAR (PTRO-INDX) = W-LINE-SRVC-YEAR
                     MOVE PTRO-OFFSET-AMT (PTRO-INDX) TO W-NUCMED-OFFSET
                     COMPUTE W-NUCMED-WA-OFFSET ROUNDED =
                             W-NUCMED-OFFSET * (.6 * A-WINX + .4)
                     PERFORM 14166-LOAD-NUCMED-TABLE
                        THRU 14166-LOAD-NUCMED-TABLE-EXIT
                        VARYING W-NUCMED-SUB FROM 1 BY 1
                        UNTIL W-NUCMED-SUB > W-NUCMED-UNIT-CNT.

       14165-PROCESS-NUCLEAR-MED-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * LOAD A NUCLEAR MEDICINE APC TABLE RECORD FOR EVERY UNIT OF  *
      * THE NUCLEAR MEDICINE LINE AND WAGE ADJUST 60% OF THE OFFSET *
      * (INSERT THE NEW RECORD IN THE CORRECT TABLE POSITION -      *
      *  HIGHEST TO LOWEST OFFSET)                                  *
      *                                                             *
      ***************************************************************
       14166-LOAD-NUCMED-TABLE.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-NUCMED-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW (LAST) ENTRY POSITION (EMPTY RECORD)        *
      *-------------------------------------------------------------*
             SET W-NUCMED-INDX TO W-NUCMED-MAX.
             INITIALIZE W-NUCMED-APC-ENTRY (W-NUCMED-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW NUCMED APC ENTRY FOR THE CURRENT    *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS OFFSET VALUE - HIGHEST TO LOWEST OFFSET                 *
      *-------------------------------------------------------------*
             PERFORM 14167-STAGE-NUCMED-ENTRY
                THRU 14167-STAGE-NUCMED-ENTRY-EXIT
                  UNTIL W-NUCMED-INDX = 1 OR
                     W-NUCMED-WA-OFFSET NOT >
                        W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE W-NUCMED-LINE-APC TO W-NUCMED-APC (W-NUCMED-INDX).
             MOVE W-NUCMED-WA-OFFSET TO
                  W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX).

       14166-LOAD-NUCMED-TABLE-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING NUCMED APC RECORD WITH A HIGHER OFFSET    *
      * DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE   *
      * NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.       *
      *                                                             *
      ***************************************************************
       14167-STAGE-NUCMED-ENTRY.

             MOVE W-NUCMED-APC-ENTRY (W-NUCMED-INDX - 1) TO
                  W-NUCMED-APC-ENTRY (W-NUCMED-INDX).
             SET W-NUCMED-INDX DOWN BY 1.

       14167-STAGE-NUCMED-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  PROCESS LINES WITH A PASS-THROUGH CONTRAST AGENT PROCEDURE *
      *        APC FOR THE PASS-THROUGH CONTRAST AGENT OFFSET       *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE PTCOFFST FOR LINE APC & LINE YEAR       *
      *      - IF FOUND, ADD A RECORD TO TABLE W-CAPROC-APC-TBL     *
      *        FOR EVERY UNIT.                                      *
      *                                                             *
      *  11/16/2009 - LOGIC ADDED EFFECTIVE STARTING JANUARY 2010   *
      *                                                             *
      ***************************************************************
       14168-PROCESS-PTCA-PROC.

      *-------------------------------------------------------------*
      * HOLD THE LINE'S APC, UNITS, & LINE ITEM DATE OF SERVICE     *
      *-------------------------------------------------------------*
             MOVE OPPS-GRP (LN-SUB)        TO W-CAPROC-LINE-APC.
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO W-CAPROC-UNIT-CNT.
             MOVE OPPS-LITEM-DOS (LN-SUB)  TO W-CAPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT CONTRAST AGENT OFFSET TABLE FOR THE APC & YEAR    *
      *-------------------------------------------------------------*
             SET PTCO-INDX TO 1.
             SEARCH PTCO-ENTRY
              AT END
                 GO TO 14168-PROCESS-PTCA-PROC-EXIT

      *-------------------------------------------------------------*
      * WHEN APC & YEAR FOUND, WAGE ADJUST OFFSET & ADD NEW RECORD  *
      * TO PT CONTRAST PROCEDURE APC TABLE FOR EVERY UNIT           *
      *-------------------------------------------------------------*
              WHEN PTCO-CONTR-APC (PTCO-INDX) = W-CAPROC-LINE-APC AND
                   PTCO-EFF-YEAR (PTCO-INDX) = W-CAPROC-SRVC-YEAR
                     MOVE PTCO-OFFSET-AMT (PTCO-INDX) TO W-CAPROC-OFFSET
                     COMPUTE W-CAPROC-WA-OFFSET ROUNDED =
                             W-CAPROC-OFFSET * (.6 * H-WINX + .4)
                     PERFORM 14168-LOAD-PTCA-PROC-TABLE
                        THRU 14168-LOAD-PTCA-PROC-TABLE-EXT
                        VARYING W-CAPROC-SUB FROM 1 BY 1
                        UNTIL W-CAPROC-SUB > W-CAPROC-UNIT-CNT.

       14168-PROCESS-PTCA-PROC-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * LOAD A PT CONTRAST AGENT PROCEDURE APC TABLE RECORD FOR     *
      * EVERY UNIT OF THE PT CONTRAST AGENT PROCEDURE LINE          *
      * (INSERT THE NEW RECORD IN THE CORRECT TABLE POSITION -      *
      *  EARLIEST TO LATEST LIDOS, THEN HIGHEST TO LOWEST OFFSET)   *
      *                                                             *
      ***************************************************************
       14168-LOAD-PTCA-PROC-TABLE.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CAPROC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW (LAST) ENTRY POSITION (EMPTY RECORD)        *
      *-------------------------------------------------------------*
             SET W-CAPROC-INDX TO W-CAPROC-MAX.
             INITIALIZE W-CAPROC-APC-ENTRY (W-CAPROC-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW CAPROC APC ENTRY FOR THE CURRENT    *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS LIDOS & OFFSET VALUE (EARLIEST TO LATEST, HIGHEST TO    *
      * LOWEST)                                                     *
      *-------------------------------------------------------------*
             PERFORM 14168-STAGE-PTCA-PROC-ENTRY
                THRU 14168-STAGE-PTCA-PROC-ENTRY-EX
                  UNTIL W-CAPROC-INDX = 1 OR
                     W-CAPROC-KEY NOT >
                        W-CAPROC-TBL-KEY (W-CAPROC-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE W-CAPROC-LINE-APC TO W-CAPROC-APC (W-CAPROC-INDX).
             MOVE W-CAPROC-KEY TO W-CAPROC-TBL-KEY (W-CAPROC-INDX).

       14168-LOAD-PTCA-PROC-TABLE-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING NUCMED APC RECORD WITH A HIGHER OFFSET    *
      * DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE   *
      * NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.       *
      *                                                             *
      ***************************************************************
       14168-STAGE-PTCA-PROC-ENTRY.

             MOVE W-CAPROC-APC-ENTRY (W-CAPROC-INDX - 1) TO
                  W-CAPROC-APC-ENTRY (W-CAPROC-INDX).
             SET W-CAPROC-INDX DOWN BY 1.

       14168-STAGE-PTCA-PROC-ENTRY-EX.
             EXIT.


      ***************************************************************
      *                                                             *
      *  PROCESS LINES WITH A PASS-THROUGH DEVICE PROCEDURE         *
      *        APC FOR THE PASS-THROUGH DEVICE OFFSET               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE OPPSPTDO FOR LINE APC                   *
      *      - IF FOUND, DETERMINE IF IT MAPS TO A PASS-THROUGH     *
      *        DEVICE HCPCS, HOW MANY IT MAPS TO, IF SOM STORE      *
      *        IT IN THE PASS-THROUGH DEVICE OFFSET PROCEDURE TABLE *
      *                                                             *
      *  08/02/2010 - LOGIC ADDED EFFECTIVE STARTING OCTOBER 2010   *
      *  12/20/2011 - LOGIC REVISED TO INCLUDE TERMINATION DATE     *
      *               AS A VALID DATE OF SERVICE                    *
      *                                                             *
      ***************************************************************
       14169-PROCESS-PTDO-PROC.

      *-------------------------------------------------------------*
      * INITIALIZE VARIBLES SPECIFIC TO THE CURRENT PROCEDURE LINE  *
      *-------------------------------------------------------------*
             MOVE 1 TO W-DOPROC-SUB.
             PERFORM UNTIL W-DOPROC-SUB > W-PTDO-ASSOC-HCPCS-MAX
                INITIALIZE W-PTDO-ASSOC-HCPCS-HCPCS (W-DOPROC-SUB)
                INITIALIZE W-PTDO-ASSOC-HCPCS-IND (W-DOPROC-SUB)
                ADD 1 TO W-DOPROC-SUB
             END-PERFORM.
             SET W-PTDO-ASSOC-HCPCS-INDX TO 1.
             MOVE 0 TO W-PTDO-ASSOC-HCPCS-MAX.
             MOVE 'N' TO W-PTDO-EOF-SWITCH.
             INITIALIZE H-PTDO-ASSOC-HCPCS-CTR.
             INITIALIZE H-PTDO-PROC-KEY.
             INITIALIZE W-PTDO-DARRAY-MAX.
             SET PTDO-INDX TO 1.

      *-------------------------------------------------------------*
      * HOLD THE LINE'S APC, UNITS, & LINE ITEM DATE OF SERVICE     *
      *-------------------------------------------------------------*
             MOVE OPPS-GRP (LN-SUB)        TO W-DOPROC-LINE-APC.
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-PTDO-PROC-UNITS.
             MOVE OPPS-LITEM-DOS (LN-SUB)  TO W-DOPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT DEVICE OFFSET TBL FOR EVERY OCCURANCE OF THE APC  *
      * AND CAPTURE EACH ASSOCIATED DEVICE HCPCS                    *
      *-------------------------------------------------------------*

             PERFORM UNTIL W-PTDO-EOF-SWITCH = 'Y'
             SEARCH PTDO-ENTRY
              AT END
                 MOVE 'Y' TO W-PTDO-EOF-SWITCH

      *-------------------------------------------------------------*
      * EACH TIME A CURRENT RECORD FOR THE APC IS FOUND, ADD THE    *
      * ASSOCIATED HCPCS TO A TABLE, HOLD THE OFFSET AMOUNT, AND    *
      * SEARCH FOR ANOTHER CURRENT RECORD                           *
      *-------------------------------------------------------------*
              WHEN (PTDO-PROC-APC (PTDO-INDX) = W-DOPROC-LINE-APC) AND
                   (PTDO-EFF-DATE (PTDO-INDX) <= W-DOPROC-SRVC-DATE) AND
                   (PTDO-TERM-DATE (PTDO-INDX) = 0 OR
                    PTDO-TERM-DATE (PTDO-INDX) >= W-DOPROC-SRVC-DATE)

                     MOVE 'N' TO W-PTDO-EOF-SWITCH

                     COMPUTE H-PTDO-PROC-WA-OFFSET =
                       ((PTDO-OFFSET-AMT (PTDO-INDX) * .60) * H-WINX) +
                        (PTDO-OFFSET-AMT (PTDO-INDX) * .40)

                     PERFORM 14169-LOAD-ASSOC-PTD-HCPCS
                        THRU 14169-LOAD-ASSOC-PTD-HCPCS-EXT

                     SET PTDO-INDX UP BY 1

             END-SEARCH
             END-PERFORM.

      *-------------------------------------------------------------*
      * SEARCH THE DEVICE OFFSET HCPCS TABLE FOR EACH HCPCS IN      *
      * THE PT DEVICE ASSOCIATED HCPCS TABLE & TRY TO MAP THE HCPCS *
      * TO THE PROCEDURE APC                                        *
      *-------------------------------------------------------------*
             IF W-PTDO-ASSOC-HCPCS-MAX > 0
                PERFORM 14169-COUNT-PTDO-MAPPINGS
                   THRU 14169-COUNT-PTDO-MAPPINGS-EXIT
                   VARYING W-DOPROC-SUB FROM 1 BY 1
                   UNTIL W-DOPROC-SUB > W-PTDO-ASSOC-HCPCS-MAX
             END-IF.

      *-------------------------------------------------------------*
      * CREATE RECORD IN THE OFFSET PROCEDURE APC TABLE IF          *
      * PROCEDURE HAS >= 1 ASSOCIATED DEVICE HCPCS ON THE CLAIM     *
      *-------------------------------------------------------------*
             IF H-PTDO-ASSOC-HCPCS-CTR > 0
                PERFORM 14169-LOAD-PTDO-PROC-TABLE
                   THRU 14169-LOAD-PTDO-PROC-TABLE-EXT
             END-IF.


       14169-PROCESS-PTDO-PROC-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * LOAD THE PASS-THROUGH DEVICE HCPCS ON THE RECORD INTO THE   *
      * PTDO ASSOCIATED HCPCS TABLE                                 *
      *                                                             *
      ***************************************************************
       14169-LOAD-ASSOC-PTD-HCPCS.

      *-------------------------------------------------------------*
      * DETERMINE IF THE RECORD'S PTDO HCPCS IS ALREADY IN THE TBL  *
      * IF IT'S NOT IN THE TBL, ADD IT, IF IT IS, DO NOT ADD IT     *
      *-------------------------------------------------------------*
             SET W-PTDO-ASSOC-HCPCS-INDX TO 1.
             SEARCH W-PTDO-ASSOC-HCPCS-ENTRY
              AT END
                 MOVE PTDO-DEV-HCPCS (PTDO-INDX) TO
                      W-PTDO-ASSOC-HCPCS-HCPCS (W-PTDO-ASSOC-HCPCS-INDX)
                 ADD 1 TO W-PTDO-ASSOC-HCPCS-MAX
                 ADD 1 TO W-PTDO-DARRAY-MAX

              WHEN W-PTDO-ASSOC-HCPCS-HCPCS(W-PTDO-ASSOC-HCPCS-INDX)
                   = PTDO-DEV-HCPCS (PTDO-INDX)
                   GO TO 14169-LOAD-ASSOC-PTD-HCPCS-EXT
              END-SEARCH.

       14169-LOAD-ASSOC-PTD-HCPCS-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE HOW MANY PT DEVICE OFFSET HCPCS MAP TO THE OFFSET *
      * PROCEDURE, AND HOW MANY PROCEDURES MAP TO THE DEVICE HCPCS  *
      *                                                             *
      ***************************************************************
       14169-COUNT-PTDO-MAPPINGS.

      *-------------------------------------------------------------*
      * SEARCH PT DEVICE OFFSET HCPCS TBL FOR THE CURRENT DEVICE    *
      * HCPCS (IN THE ASSOC. HCPCS TBL)                             *
      *-------------------------------------------------------------*
             SET W-PTDO-HCPCS-INDX TO 1.
             SEARCH W-PTDO-HCPCS-ENTRY
              AT END
                 MOVE 'N' TO W-PTDO-ASSOC-HCPCS-IND(W-DOPROC-SUB)

              WHEN W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX) =
                   W-PTDO-ASSOC-HCPCS-HCPCS(W-DOPROC-SUB)
                   MOVE 'Y' TO W-PTDO-ASSOC-HCPCS-IND(W-DOPROC-SUB)
                   ADD 1 TO H-PTDO-ASSOC-HCPCS-CTR
                   ADD 1 TO W-PTDO-HCPCS-PROC-CNT(W-PTDO-HCPCS-INDX).

       14169-COUNT-PTDO-MAPPINGS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * LOAD A PT DEVICE OFFSET PROCEDURE APC TABLE RECORD FOR      *
      * THE CURRENT PROCEDURE LINE IF THERE IS AT LEAST ONE         *
      * ASSOCIATED PT DEVICE ON THE CLAIM                           *
      * (INSERT THE NEW RECORD IN THE CORRECT TABLE POSITION -      *
      *  HIGHEST TO LOWEST OFFSET, THEN HIGHEST TO LOWEST UNITS)    *
      *                                                             *
      ***************************************************************
       14169-LOAD-PTDO-PROC-TABLE.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTDO-PROC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW (LAST) ENTRY POSITION (EMPTY RECORD)        *
      *-------------------------------------------------------------*
             SET W-PTDO-PROC-INDX TO W-PTDO-PROC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW PROC APC ENTRY FOR THE CURRENT      *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS OFFSET & UNITS (HIGHEST TO LOWEST, HIGHEST TO LOWEST)   *
      *-------------------------------------------------------------*
             PERFORM 14169-STAGE-PTDO-PROC-ENTRY
                THRU 14169-STAGE-PTDO-PROC-ENTRY-EX
                  UNTIL W-PTDO-PROC-INDX = 1 OR
                     H-PTDO-PROC-KEY NOT >
                        W-PTDO-PROC-KEY (W-PTDO-PROC-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE W-DOPROC-LINE-APC TO
                  W-PTDO-PROC-APC (W-PTDO-PROC-INDX).
             MOVE LN-SUB TO W-PTDO-PROC-LNSUB (W-PTDO-PROC-INDX).
             MOVE H-PTDO-PROC-UNITS TO
                  W-PTDO-PROC-UNITS (W-PTDO-PROC-INDX).
             MOVE H-PTDO-PROC-WA-OFFSET TO
                  W-PTDO-PROC-WA-OFFSET (W-PTDO-PROC-INDX).
             MOVE 0 TO W-PTDO-PROC-DEVICE-CNT (W-PTDO-PROC-INDX).
             MOVE 0 TO W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX).
             MOVE 0 TO W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX).
             MOVE SPACES TO W-PTDO-PROC-USED (W-PTDO-PROC-INDX).

      *------------------------------------------------------------*
      * LOAD HCPCS IN ASSOCIATED HCPCS TABLE INTO THE EMPTY RECORD *
      *------------------------------------------------------------*
             MOVE 1 TO W-DOPROC-SUB.
             MOVE 0 TO W-PTDO-DARRAY-SIZE (W-PTDO-PROC-INDX).
             PERFORM UNTIL W-DOPROC-SUB > W-PTDO-ASSOC-HCPCS-MAX
               IF W-PTDO-ASSOC-HCPCS-IND (W-DOPROC-SUB) = 'Y'
                MOVE W-PTDO-ASSOC-HCPCS-HCPCS (W-DOPROC-SUB) TO
                  W-PTDO-PROC-DHCPCS (W-PTDO-PROC-INDX, W-DOPROC-SUB)
                ADD 1 TO W-PTDO-DARRAY-SIZE (W-PTDO-PROC-INDX)
               END-IF
               ADD 1 TO W-DOPROC-SUB
             END-PERFORM.


       14169-LOAD-PTDO-PROC-TABLE-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING PROCEDURE RECORD WITH A LOWER OFFSET &    *
      * LOWER UNITS DOWN ONE RECORD POSITION AND SET THE EMPTY      *
      * RECORD FOR THE NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD  *
      * POSITION.                                                   *
      *                                                             *
      ***************************************************************
       14169-STAGE-PTDO-PROC-ENTRY.

             MOVE W-PTDO-PROC-ENTRY (W-PTDO-PROC-INDX - 1) TO
                  W-PTDO-PROC-ENTRY (W-PTDO-PROC-INDX).
             SET  W-PTDO-PROC-INDX DOWN BY 1.

       14169-STAGE-PTDO-PROC-ENTRY-EX.
             EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH COMPOSITE          *
      *  ADJUSTMENT FLAG NOT = '00' & POPULATE COMPOSITE APC TABLE  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY COMPOSITE ADJUSTMENT FLAG (CAF) -   *
      *    LOWEST TO HIGHEST FLAG VALUE (01 - NN)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH CAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *  11/12/2008 - LOGIC REVISED FOR CY 2009 TO USE THE          *
      *               COMPOSITE ADJUSTMENT FLAG INSTEAD OF THE      *
      *               PAYMENT ADJUSTMENT FLAG, VARIABLE H-CMP-CAF   *
      *               HOLDS COMPOSITE ADJUSTMENT FLAG, VARIABLE     *
      *               W-CMP-PAF RETAINED AND NOW HOLDS THE CAF      *
      *               (RETAINED TO CONTINUE USE OF EXISTING TABLE)  *
      *                                                             *
      ***************************************************************
       14170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S COMPOSITE ADJUSTMENT FLAG FOR TABLE SEARCH   *
      *-------------------------------------------------------------*
             MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE CAF         *
      *-------------------------------------------------------------*
                PERFORM 14171-SEARCH-CAF
                   THRU 14171-SEARCH-CAF-EXIT.

       14170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       14171-SEARCH-CAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS NOT      *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 14172-ADD-ENTRY
                      THRU 14172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS ALREADY  *
      * IN THE TABLE, UPDATE THE ENTRY                              *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                   PERFORM 14173-UPDATE-ENTRY
                      THRU 14173-UPDATE-ENTRY-EXIT.

       14171-SEARCH-CAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       14172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS COMPOSITE ADJUSTMENT FLAG (CAF) - LOWEST TO HIGHEST CAF *
      *-------------------------------------------------------------*
             PERFORM 14174-STAGE-CMP-ENTRY
                THRU 14174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-CAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-CAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       14172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * COMPOSITE ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE       *
      *                                                             *
      ***************************************************************
       14173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE CAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       14173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER CAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       14174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       14174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       14175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 14175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       14175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   APPLY STEREOTACTIC RADIOSURGERY (SRS) CAP POLICY:         *
      *   WHEN APPLICABLE, CHANGE SRS HCPCS 77371'S APC ASSIGNMENT  *
      *   TO '00067' TO CAP PAYMENT AT APC 00067'S RATE             *
      *                                                             *
      *  PROVIDER TYPES EXEMPT FROM THIS POLICY:                    *
      *    - LOCATED IN RURAL AREA                                  *
      *    - RURAL REFERRAL CENTER                                  *
      *    - SOLE COMMUNITY HOSPITAL                                *
      *                                                             *
      *  02/08/2013- CREATED THIS PARAGRAPH                        *
      *                                                             *
      ***************************************************************
       14176-APPLY-SRS-CAP.

      *-------------------------------------------------------------*
      *  MOVE PROVIDER GEOGRAPHIC AND WAGE INDEX CBSA TO FLAG FIELDS*
      *-------------------------------------------------------------*
             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.

      *-------------------------------------------------------------*
      *  IDENTIFY PROVIDERS EXEMPT FROM THE SRS PAYMENT CAP POLICY: *
      *    1) RURAL: RURAL GEOGRAPHIC OR RURAL WAGE INDEX CBSA      *
      *    2) RURAL REFERRAL CENTER: PROVIDER TYPE 07               *
      *    3) SOLE COMMUNITY HOSPITAL: PROVIDER TYPE 16,17,21,OR 22 *
      *-------------------------------------------------------------*
             IF ((RURAL-GEO OR RURAL-WI) OR
                 (L-PSF-PROV-TYPE = '07') OR
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))
                GO TO 14176-APPLY-SRS-CAP-EXIT

      *-------------------------------------------------------------*
      *  FOR PROVIDERS ELIGIBLE FOR SRS CAP, CHANGE APC TO '00067'  *
      *-------------------------------------------------------------*
             ELSE
                MOVE '00067' TO OPPS-GRP (LN-SUB)
             END-IF.


       14176-APPLY-SRS-CAP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      REDUCE APC PAYMENT OF LINES FROM PROVIDERS WITH A      *
      *      SPACE IN THE QUALITY INDICATOR FIELD OF THE OPSF       *
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      *  11/16/2010 - ADDED SI = U (BRACHY) TO LOGIC                *
      *                                                             *
      ***************************************************************
       14180-REDUCE-APC-PYMT.

      *-------------------------------------------------------------*
      *  SPECIFY LINES ELIGIBLE FOR REDUCTION                       *
      *-------------------------------------------------------------*
             IF ( L-PSF-HOSP-QUAL-IND = ' ' )  AND

                (  (OPPS-SRVC-IND (LN-SUB) = ' P')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' R')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' S' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01491' AND
                           OPPS-GRP (LN-SUB) <= '01537'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' T' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01539' AND
                           OPPS-GRP (LN-SUB) <= '01574'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' U')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' V')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' X')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J1')  ) THEN

                COMPUTE H-APC-PYMT ROUNDED = H-APC-PYMT * 0.980
                MOVE 11 TO A-RETURN-CODE (LN-SUB)

             END-IF.


       14180-REDUCE-APC-PYMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       14200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   IF W-WINX-LOOKUP
                      MOVE  50  TO A-CLM-RTN-CODE
                   END-IF
                   GO TO 14200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA

      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 14210-WAGE-LOOKUP.

      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0 OR NOT NUMERIC             *
      *   *AND* NOT ON RURAL FLOOR LOOKUP                           *
      ***************************************************************

             IF (H-WINX = 0 OR H-WINX NOT NUMERIC) AND
                 W-WINX-LOOKUP THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       14200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       14210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE MEETS THE CRITERIA:       *
      *  - MUST NOT BE AFTER THE LATEST WAGE INDEX EFFECTIVE DATE   *
      *    THAT CAN BE USED BY THE CLAIM                            *
      *  - EXCEPT FOR INDIAN HEALTH PROVIDERS (CBSAS 98 AND 99),    *
      *    MUST BE WITHIN THE CLAIM'S CALENDAR YEAR                 *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD / LATEST         *
      * EFFECTIVE DATE FOR THE CBSA)                                *
      ***************************************************************
             MOVE WCW-DTCD (W-SUB3) TO W-WCW-DTCD.

             IF W-WCW-DTCD NOT > WCD-DTCD (WCD-SUB) AND

                ( (WCD-DATE (W-WCW-DTCD) >= W-CY-BEGIN-DATE AND
                   WCD-DATE (W-WCW-DTCD) <= W-CY-END-DATE AND
                   H-PSF-CBSA NOT = '   98' AND
                   H-PSF-CBSA NOT = '   99') OR

                  (H-PSF-CBSA = '   98' OR
                   H-PSF-CBSA = '   99') )

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *   *ONLY VALID FOR WAGE INDEX LOOKUP, NOT RURAL FLOOR*       *
      *   IF WAGE INDEX > FLOOR, OVERWRITE H-WINX                   *
      *-------------------------------------------------------------*
                IF L-PSF-SPEC-PYMT-IND = 'Y' AND W-WINX-LOOKUP THEN
                   IF WCW-WINX2 (W-SUB3) > H-WINX THEN
                      MOVE WCW-WINX2 (W-SUB3) TO H-WINX
                   END-IF
      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *   IF WAGE INDEX > FLOOR OR LOOKING UP RURAL FLOOR, STORE    *
      *   RESULT IN H-WINX.                                         *
      *-------------------------------------------------------------*
                ELSE
                   IF (WCW-WINX1 (W-SUB3) > H-WINX OR W-FLOOR-LOOKUP)
                      MOVE WCW-WINX1 (W-SUB3) TO H-WINX
                   END-IF
                END-IF


      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE DID NOT MEET THE CRITERIA *
      *  - AFTER THE LATEST EFFECTIVE DATE THE CLAIM CAN USE -OR-   *
      *  - NOT WITHIN THE CLAIM'S CALENDAR YEAR AND NOT IN CBSA     *
      *    98 OR 99                                                 *
      *  GO TO THE PRIOR RECORD FOR THIS CBSA WITH AN EARLIER DATE  *
      *  IN THE CBSA WAGE INDEX TABLE.                              *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *  AGAIN AND REPEAT THE PROCESS
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 14210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      * >10-28-2014 ONLY VALID FOR WAGE INDEX PASS, NOT RURAL FLOOR *
      *-------------------------------------------------------------*
                ELSE

                   IF W-WINX-LOOKUP
                      MOVE 0 TO H-WINX
                END-IF
             END-IF.

       14210-WAGE-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       14250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 14250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       14250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       14300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 14350-STAGE-ENTRY
                THRU 14350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX      TO W-WINX (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       14300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       14350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       14350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       14375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 14385-STAGE-ENTRY
                THRU 14385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX     TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       14375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       14385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       14385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            POPULATE PASS-THROUGH DEVICE TABLE               *
      *        (FOR ASSOCIATED PROCEDURE PAYMENT & CHARGE           *
      *            ADJUSTMENTS IN THE OUTLIER ROUTINE)              *
      *            (IMPLEMENTED IN APRIL 2008 PRICER)               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER RECORDS AS FOLLOWS -                                 *
      *     1. HCPCS, ASCENDING                                     *
      *     2. LOWEST TO HIGHEST LINE SUBSCRIPT                     *
      *                                                             *
      *  02/11/2008 - LOGIC ADDED FOR CY 2008, QTR 2                *
      *  11/12/2008 - LOGIC NOT CHANGED, NO CY 2009 PT DEVICES      *
      *                                                             *
      ***************************************************************
       14390-PASS-THRU-DEVICES.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-PTD-INDX TO W-PTD-MAX.
             INITIALIZE W-PTD-ENTRY (W-PTD-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW RECORD SHOULD BE ENTERED INTO THE   *
      * TABLE ACCORDING TO ITS HCPCS AND THE HCPCS OF THE RECORDS   *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST HCPCS              *
      *-------------------------------------------------------------*
             PERFORM 14391-STAGE-ENTRY
                THRU 14391-STAGE-ENTRY-EXIT
                   UNTIL W-PTD-INDX = 1 OR
                     W-PTD-LINE-HCPCS NOT <
                       W-PTD-HCPCS (W-PTD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE OPPS-HCPCS (LN-SUB)    TO W-PTD-HCPCS (W-PTD-INDX).
             MOVE LN-SUB                 TO W-PTD-SUB (W-PTD-INDX).
             MOVE OPPS-SUB-CHRG (LN-SUB) TO W-PTD-SUB-CHRG (W-PTD-INDX).

       14390-PASS-THRU-DEVICES-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING PASS-THROUGH DEVICE RECORD WITH A       *
      *   HIGHER HCPCS UP ONE RECORD POSITION AND SET THE INDEX OF  *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       14391-STAGE-ENTRY.

             MOVE W-PTD-ENTRY (W-PTD-INDX - 1) TO
                  W-PTD-ENTRY (W-PTD-INDX).
             SET W-PTD-INDX DOWN BY 1.

       14391-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE DATA     *
      *              (IMPLEMENTED IN APRIL 2008 PRICER)             *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  02/11/2008 - LOGIC ADDED FOR CY 2008, QTR 2                *
      *                                                             *
      ***************************************************************
       14392-PASS-THRU-DEV-PROCS.

      *-------------------------------------------------------------*
      * LOOP THROUGH ELIGIBLE PROCEDURE'S PASS-THROUGH DEVICE TABLE *
      *-------------------------------------------------------------*
             PERFORM 14393-PERFORM-SEARCH
                THRU 14393-PERFORM-SEARCH-EXIT
                VARYING W-PTD-PROC-SUB FROM 1 BY 1
                UNTIL W-PTD-PROC-SUB > W-PTD-CNT.

       14392-PASS-THRU-DEV-PROCS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE                                    *
      *                                                             *
      ***************************************************************
       14393-PERFORM-SEARCH.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR ALL OCCURANCES    *
      * OF THE PASS-THRU DEVICE HCPCS IN THE PASS-THRU DEVICE TABLE.*
      * THIS IS DONE FOR ALL PASS-THROUGH DEVICES THE PROCEDURE IS  *
      * ELIGIBLE FOR.                                               *
      *-------------------------------------------------------------*
                 MOVE 'N' TO W-END-OF-PTD-TBL.

                 IF W-PTD-PROC-HCPCS (W-PTD-PROC-SUB) NOT = '     '
                    SET W-PTD-INDX TO 1
                    PERFORM 14394-SEARCH-PTD-HCPCS
                       THRU 14394-SEARCH-PTD-HCPCS-EXIT
                      UNTIL W-END-OF-PTD-TBL = 'Y'
                 END-IF.

       14393-PERFORM-SEARCH-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE                                    *
      *                                                             *
      ***************************************************************
       14394-SEARCH-PTD-HCPCS.

             MOVE 'N' TO W-END-OF-PTD-TBL.

      *-------------------------------------------------------------*
      * SEARCH PASS-THROUGH DEVICE TABLE                            *
      *-------------------------------------------------------------*
             SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THERE ARE NO MORE OCCURANCES OF THE PASS-THROUGH DEVICE, *
      * STOP THE SEARCH AND INDICATE END OF FILE                    *
      *-------------------------------------------------------------*
                AT END
                   MOVE 'Y' TO W-END-OF-PTD-TBL
                   GO TO 14394-SEARCH-PTD-HCPCS-EXIT

      *-------------------------------------------------------------*
      * IF THE PASS-THROUGH DEVICE IS FOUND, INDICATE NOT END OF    *
      * FILE AND UPDATE THE DEVICE'S RECORD WITH THE PROCEDURE DATA *
      *-------------------------------------------------------------*
                WHEN  W-PTD-HCPCS (W-PTD-INDX) =
                      W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)

                         MOVE 'N' TO W-END-OF-PTD-TBL

                         PERFORM 14395-UPDATE-ENTRY
                            THRU 14395-UPDATE-ENTRY-EXIT

                         SET W-PTD-INDX UP BY 1

             END-SEARCH.

       14394-SEARCH-PTD-HCPCS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING PASS-THROUGH DEVICE RECORD WITH THE     *
      * CURRENT ELIGIBLE PROCEDURE'S DATA                           *
      *                                                             *
      ***************************************************************
       14395-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * UPDATE PASS-THROUGH DEVICE RECORD                           *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTD-PROC-CNT (W-PTD-INDX).

             ADD OPPS-SRVC-UNITS (LN-SUB) TO
                 W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX).

       14395-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SUM PASS-THROUGH CONTRAST AGENT OFFSET AMOUNT(S) FOR EACH   *
      * DAY ON WHICH A PASS-THROUGH CONTRAST AGENT APPEARS          *
      *                                                             *
      ***************************************************************
       14396-TOTAL-DAY-PTCA-OFFS.

      *-------------------------------------------------------------*
      * CAPTURE DATE OF SERVICE FROM PT CONTRAST AGENT DAY TABLE    *
      *-------------------------------------------------------------*
             MOVE W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX)
               TO W-CAPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * MOVE TO FIRST RECORD IN PT CONTRAST AGENT PROCEDURE APC TBL *
      *-------------------------------------------------------------*
             SET W-CAPROC-INDX TO 1.

      *-------------------------------------------------------------*
      * START COUNTER THAT MONITORS THE # OF OFFSETS ADDED          *
      *-------------------------------------------------------------*
             MOVE 1 TO W-CAPROC-UNIT-CNT.

             SEARCH W-CAPROC-APC-ENTRY

      *-------------------------------------------------------------*
      * DATE OF SERVICE NOT FOUND IN TABLE, STOP PROCESS            *
      *-------------------------------------------------------------*
                AT END
                   GO TO 14396-TOTAL-DAY-PTCA-OFFS-EXIT

      *-------------------------------------------------------------*
      * DATE OF SERVICE FOUND IN TABLE, ACCUMULATE OFFSETS          *
      *-------------------------------------------------------------*
                WHEN W-CAPROC-LIDOS (W-CAPROC-INDX) = W-CAPROC-SRVC-DATE
                     PERFORM UNTIL
      *     *-------------------------------------------------------*
      *     * STOP SEARCH WHEN END OF TABLE REACHED                 *
      *     *-------------------------------------------------------*
                        (W-CAPROC-INDX > W-CAPROC-MAX) OR
      *     *-------------------------------------------------------*
      *     * STOP SEARCH WHEN NUMBER OF DAY'S HCPCS LINES EXCEEDED *
      *     *-------------------------------------------------------*
                        (W-CAPROC-UNIT-CNT >
                           W-PTCA-DAY-HCPCS-CNT (W-PTCA-DAY-INDX)) OR
      *     *-------------------------------------------------------*
      *     * STOP SEARCH WHEN DATE OF SERVICE CHANGES              *
      *     *-------------------------------------------------------*
                        (W-CAPROC-LIDOS (W-CAPROC-INDX) NOT =
                           W-CAPROC-SRVC-DATE)

      *     *-------------------------------------------------------*
      *     * ADD PT CONTRAST AGENT PROCEDURE OFFSET TO DAY TOTAL   *
      *     *-------------------------------------------------------*
                        COMPUTE W-PTCA-DAY-TOT-OFFSET (W-PTCA-DAY-INDX)
                          ROUNDED =
                             W-PTCA-DAY-TOT-OFFSET (W-PTCA-DAY-INDX) +
                             W-CAPROC-WAGE-ADJ-OFFSET (W-CAPROC-INDX)

      *     *-------------------------------------------------------*
      *     * SET POINTER TO NEXT PROCEDURE RECORD                  *
      *     *-------------------------------------------------------*
                        SET W-CAPROC-INDX UP BY 1
                        ADD 1 TO W-CAPROC-UNIT-CNT
                     END-PERFORM
             END-SEARCH.

       14396-TOTAL-DAY-PTCA-OFFS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MAP EACH PT DEVICE HCPCS ON THE CLAIM TO AN OFFSET          *
      * PROCEDURE WHEN POSSIBLE - FIRST PASS: ASSIGN EACH PROCEDURE *
      * ONLY ONE PT DEVICE                                          *
      *                                                             *
      ***************************************************************
       14397-PTDO-MAPPINGS-1.

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLES SPECIFIC TO THIS PT HCPCS RECORD       *
      *-------------------------------------------------------------*
             MOVE 'N' TO W-PTDO-EOF-SWITCH.
             SET W-PTDO-PROC-INDX TO 1.

      *-------------------------------------------------------------*
      * SEARCH PTDO PROCEDURE TABLE FOR A PROCEDURE THAT MAPS TO    *
      * THE CURRENT PT DEVICE                                       *
      *-------------------------------------------------------------*
             PERFORM UNTIL W-PTDO-EOF-SWITCH = 'Y'
             SEARCH W-PTDO-PROC-ENTRY

                AT END
                   MOVE 'Y' TO W-PTDO-EOF-SWITCH
                   GO TO 14397-PTDO-MAPPINGS-1-EXIT

      *-------------------------------------------------------------*
      * PROCEDURE NOT ASSIGNED TO A PT DEVICE, SEE IF IT MAPS       *
      *-------------------------------------------------------------*
                WHEN W-PTDO-PROC-USED (W-PTDO-PROC-INDX) NOT = 'Y'

                   SET W-PTDO-DARRAY-INDX TO 1
                   MOVE W-PTDO-DARRAY-SIZE (W-PTDO-PROC-INDX) TO
                        W-PTDO-DARRAY-MAX

                   SEARCH W-PTDO-PROC-DARRAY
                      AT END
                         CONTINUE

      *-------------------------------------------------------------*
      * PROCEDURE MAPS TO CURRENT PT DEVICE HCPCS                   *
      *-------------------------------------------------------------*
                      WHEN W-PTDO-PROC-DHCPCS (W-PTDO-PROC-INDX,
                                               W-PTDO-DARRAY-INDX) =
                           W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX)

                         MOVE W-PTDO-PROC-APC (W-PTDO-PROC-INDX) TO
                             W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX)

                         MOVE W-PTDO-PROC-LNSUB (W-PTDO-PROC-INDX) TO
                             W-PTDO-HCPCS-PROC-LNSUB (W-PTDO-HCPCS-INDX)

                         MOVE 'Y' TO W-PTDO-PROC-USED (W-PTDO-PROC-INDX)

                         MOVE 1 TO
                             W-PTDO-PROC-DEVICE-CNT (W-PTDO-PROC-INDX)

                         MOVE W-PTDO-HCPCS-SUB-CHRG (W-PTDO-HCPCS-INDX)
                           TO W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX)

                         MOVE W-PTDO-HCPCS-UNITS (W-PTDO-HCPCS-INDX) TO
                             W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX)

                         GO TO 14397-PTDO-MAPPINGS-1-EXIT
                   END-SEARCH
                   SET W-PTDO-PROC-INDX UP BY 1
             END-SEARCH
             END-PERFORM.

       14397-PTDO-MAPPINGS-1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MAP EACH PT DEVICE HCPCS ON THE CLAIM TO AN OFFSET          *
      * PROCEDURE WHEN POSSIBLE - SECOND PASS: ASSIGN PROCEDURES    *
      * ADDITIONAL PT DEVICES WHEN NECESSARY                        *
      *                                                             *
      ***************************************************************
       14397-PTDO-MAPPINGS-2.

      *-------------------------------------------------------------*
      * DETERMINE WHETHER THE PT DEVICE HCPCS NEEDS A PROCEDURE     *
      *-------------------------------------------------------------*
             IF W-PTDO-HCPCS-PROC-CNT (W-PTDO-HCPCS-INDX) > 0 AND
                W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX) = SPACES
                CONTINUE
             ELSE
                GO TO 14397-PTDO-MAPPINGS-2-EXIT
             END-IF.
             SET W-PTDO-PROC-INDX TO 1.

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLES SPECIFIC TO THIS PT HCPCS RECORD       *
      *-------------------------------------------------------------*
             MOVE 'N' TO W-PTDO-EOF-SWITCH.

      *-------------------------------------------------------------*
      * SEARCH PTDO PROCEDURE TABLE FOR A PROCEDURE THAT MAPS TO    *
      * THE CURRENT PT DEVICE                                       *
      *-------------------------------------------------------------*
             PERFORM UNTIL W-PTDO-EOF-SWITCH = 'Y'
             SEARCH W-PTDO-PROC-ENTRY

                AT END
                   MOVE 'Y' TO W-PTDO-EOF-SWITCH
                   GO TO 14397-PTDO-MAPPINGS-2-EXIT

      *-------------------------------------------------------------*
      * PROCEDURE ALREADY ASSIGNED TO PT DEVICE(S)                  *
      *-------------------------------------------------------------*
                WHEN W-PTDO-PROC-USED (W-PTDO-PROC-INDX) = 'Y' OR
                     W-PTDO-PROC-USED (W-PTDO-PROC-INDX) = 'S'

                   SET W-PTDO-DARRAY-INDX TO 1
                   MOVE W-PTDO-DARRAY-SIZE (W-PTDO-PROC-INDX) TO
                        W-PTDO-DARRAY-MAX
                   SEARCH W-PTDO-PROC-DARRAY
                      AT END
                         CONTINUE

      *-------------------------------------------------------------*
      * PROCEDURE MAPS TO CURRENT PT DEVICE HCPCS, SEE IF IT MAPS   *
      *-------------------------------------------------------------*
                      WHEN W-PTDO-PROC-DHCPCS (W-PTDO-PROC-INDX,
                                               W-PTDO-DARRAY-INDX) =
                           W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX)

                         MOVE W-PTDO-PROC-APC (W-PTDO-PROC-INDX) TO
                             W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX)

                         MOVE W-PTDO-PROC-LNSUB (W-PTDO-PROC-INDX) TO
                             W-PTDO-HCPCS-PROC-LNSUB (W-PTDO-HCPCS-INDX)

                         MOVE 'S' TO W-PTDO-PROC-USED (W-PTDO-PROC-INDX)

                         ADD 1 TO
                             W-PTDO-PROC-DEVICE-CNT (W-PTDO-PROC-INDX)

                         COMPUTE W-PTDO-PROC-TOT-DCHRGS
                                 (W-PTDO-PROC-INDX) =
                           W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX) +
                           W-PTDO-HCPCS-SUB-CHRG (W-PTDO-HCPCS-INDX)

                         COMPUTE W-PTDO-PROC-TOT-DUNITS
                                 (W-PTDO-PROC-INDX) =
                           W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX) +
                           W-PTDO-HCPCS-UNITS (W-PTDO-HCPCS-INDX)

                         GO TO 14397-PTDO-MAPPINGS-2-EXIT
                   END-SEARCH
                   SET W-PTDO-PROC-INDX UP BY 1
             END-SEARCH
             END-PERFORM.

       14397-PTDO-MAPPINGS-2-EXIT.
           EXIT.




      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PYMNTS, DEDUCTIBLES, REIM., & COINSURANCE,  *
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       14400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 14400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 14550-CALC-STANDARD
                   THRU 14550-CALC-STANDARD-EXIT
             ELSE
                GO TO 14400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRUG COINSURANCE TABLE FOR LATER PROCESSING        *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET GJK-FLAG WHEN SERVICE = G OR K                       *
      *-------------------------------------------------------------*
             IF (A-RETURN-CODE (LN-SUB) <  30) AND
                NOT PKG-BLD-DED-LINE
                PERFORM 14450-ADJ-PROC-COIN
                   THRU 14450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 14500-ADJ-CHRGS
                THRU 14500-ADJ-CHRGS-EXIT.


      *-------------------------------------------------------------*
      *   UPDATE PASS-THROUGH DEVICE TABLE W/ ELIGIBLE PROCEDURE    *
      *   LINE DATA (FOR ASSOCIATED PROCEDURE OUTLIER CALC)         *
      *   EFFECTIVE CY 2008 QTR 2, LOGIC ADDED 02/12/2008           *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) < 30 AND
                PTD-FLAG = 'Y' AND
                (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                 ' X' OR 'J1') THEN
                  PERFORM 14670-SET-PTD-PROC-FLAG
                     THRU 14670-SET-PTD-PROC-FLAG-EXIT

                  IF PTD-PROC-FLAG = 'Y'
                     PERFORM 14392-PASS-THRU-DEV-PROCS
                        THRU 14392-PASS-THRU-DEV-PROCS-EXIT
                  END-IF

             END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

                COMPUTE A-DEVICE-CREDIT-QD =
                        A-DEVICE-CREDIT-QD + H-LINE-DEVCR-AMT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 14840-PROCESS-TYPE2     *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)

               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       14400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE DRUG COINSURANCE ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: DRUG / BLOOD LINE                       *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY DRUG LINE          *
      *   ("DRUG" REFERS TO ANY SI = G OR K LINE FOR SIMPLICITY)    *
      *                                                             *
      * DRUG COINSURANCE RECORD COMBINATIONS:                       *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       DRUG(S) ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO DRUG(S) ADMINISTERED ON THE *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH DRUG(S) ADMINISTERED ON THE    *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = G OR K =>          *
      *       DRUG ADMINSTERED ON THE DATE OF SERVICE               *
      *                                                             *
      ***************************************************************
       14450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                PERFORM 14455-SEARCH-KEY
                   THRU 14455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = G, K, & R LINES ("DRUG" & BLOOD)               *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET GJK-FLAG TO INDICATE "DRUG" LINE                        *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO GJK-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                   PERFORM 14455-SEARCH-KEY
                      THRU 14455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY DRUG LINE) *
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = G OR K  *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 14475-STAGE-DCP-ENTRY
                      THRU 14475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, "DRUG"                                       *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       14450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW DRUG/DEVICE COINSURANCE TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       14455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH DRUG/DEVICE COINSURANCE TABLE STARTING AT ENTRY #1   *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 14460-ADD-ENTRY
                      THRU 14460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 14465-UPDATE-ENTRY
                      THRU 14465-UPDATE-ENTRY-EXIT.

       14455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE DRUG / DEVICE COINSURANCE TABLE                         *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       14460-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 14475-STAGE-DCP-ENTRY
                THRU 14475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, "DRUG"                                       *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       14460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING DRUG COINSURANCE RECORD WITH THE SAME   *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       14465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR "DRUG" LINES - ACCUMULATE DAY'S TOTAL "DRUG" COIN DUE   *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A "DRUG" LINE, UPDATE THE RECORD  *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 14485-REPLACE-TYPE1
                     THRU 14485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 14480-RANK-COIN
                     THRU 14480-RANK-COIN-EXIT.

       14465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING DRUG COINSURANCE RECORD WITH A HIGHER     *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       14475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       14475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST WAGE ADJ.  *
      * NATIONAL COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE  *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       14480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       14480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = G OR K   *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = DRUG / BLOOD LINE NEW COINSURANCE AMOUNT(S)       *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       14485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       14485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 14600-ADJ-CHRG-OUTL.)                     *
      *                                                             *
      ***************************************************************
       14500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
      * 12/18/2009 - ADD SIS R & U, WHICH ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P' OR ' R' OR ' U' OR 'J1')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                AND NOT PKG-BLD-DED-LINE
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       14500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    AND DRUGS & TAKE PT DEVICE OFFSET WHEN APPLICABLE        *
      * 5. CALCULATE AND APPLY DEVICE CREDIT                        *
      *                                                             *
      ***************************************************************
       14550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 14655-SET-BD-HCPCS-FLAG
                THRU 14655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      *   FLAG LINE IF ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND CLAIM  *
      *   HAS A COMPREHENSIVE APC; TREAT AS PACKAGED LINE           *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             ELSE
                  MOVE 'N' TO PKG-BLD-DED-LINE-FLAG
             END-IF.

      *-------------------------------------------------------------*
      * FLAG LINE IF LINE HCPCS IS A PASS-THROUGH RADIOPHARM HCPCS  *
      * ** QUARTERLY UPDATES TO TABLE **                            *
      *-------------------------------------------------------------*
      * 02/10/2009 - PT RADIOPHARM HCPCS CHECK ADDED                *
      *-------------------------------------------------------------*
             PERFORM 14680-SET-PTRADIO-LINE-FLAG
                THRU 14680-SET-PTRADIO-LINE-FL-EXIT.

      *-------------------------------------------------------------*
      * FLAG LINE IF LINE HCPCS IS A PASS-THROUGH CONTRAST AGENT    *
      * HCPCS ** QUARTERLY UPDATES TO TABLE **                      *
      *-------------------------------------------------------------*
      * 11/16/2009 - PT CONTRAST AGENT HCPCS CHECK ADDED            *
      *-------------------------------------------------------------*
             PERFORM 14681-SET-PTCA-LINE-FLAG
                THRU 14681-SET-PTCA-LINE-FL-EXIT.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).

      ***************************************************************
      * CALCULATE DEVICE CREDIT FOR ELIGIBLE LINE(S) AND            *
      * REDUCE THE APC PAYMENT BY THE CREDIT AMOUNT                 *
      *-------------------------------------------------------------*
      * 11/18/2013- NEW LOGIC FOR CY 2014; REPLACES DEVICE          *
      *              REDUCTION LOGIC                                *
      ***************************************************************
             IF DEVCR-CLAIM-FLAG = 'Y'
                PERFORM 14550-DEVICE-CREDIT
                   THRU 14550-DEVICE-CREDIT-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, OR X LINES           *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X' OR 'J1') THEN
                  PERFORM 14550-SCH-ADJ
                     THRU 14550-SCH-ADJ-EXIT
                  PERFORM 14560-CALC-BENE-DEDUCT
                     THRU 14560-CALC-BENE-DEDUCT-EXIT

                  IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                     PERFORM 14550-PHP-PMT-FOR-OUTL
                        THRU 14550-PHP-PMT-FOR-OUTL-EXIT
                  END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (DEVICE) LINES, PAYMENT IND.   *
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      *-------------------------------------------------------------*
      * 01/01/2009 - BRACHYTHERAPY SERVICES ADDED FOR CY 2009       *
      * 11/15/2009 - BRACHYTHERAPY SERVICES (SI=U) REMOVED CY 2010  *
      *            - THERAPEUTIC RADIOPHARMS' SI NOT 'H' FOR CY2010 *
      * 08/11/2010 - NEW PASS-THROUGH DEVICE OFFSET LOGIC ADDED IN  *
      *              PARAGRAPH 10555-CALC-H-STANDARD                *
      ***************************************************************
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' H') THEN
                 IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                       OPPS-PYMT-IND (LN-SUB) = ' 6')
                   PERFORM 14555-CALC-H-STANDARD
                      THRU 14555-CALC-H-STANDARD-EXIT
                   PERFORM 14560-CALC-BENE-DEDUCT
                      THRU 14560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 14550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = G, K, R & U LINES; THE PMT. IND. *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      * 11/15/2009 - ADDED BRACHYTHERAPY SERVICES (SI=U) FOR CY2010 *
      *              THERAPEUTIC RADIOPHARMS' SI=K FOR CY 2010      *
      * 11/16/2009 - ADD LOGIC TO ADJUST PT CONTRAST AGENT HCPCS    *
      *              LINE PAYMENT BY OFFSET                         *
      * 05/10/2016 - CALCULATE BLOOD DEDUCTIBLE & LINE PAYMENT FOR  *
      *              BLOOD DEDUCTIBLE LINES ON COMPREHEMSIVE APC    *
      *              CLAIMS (THESE LINES WERE PREVIOUSLY PACKAGED)  *
      *            - ADD LOGIC TO EXEMPT BLOOD DEDUCTIBLE LINES ON  *
      *              COMPREHENSIVE APC CLAIMS FROM REIM, COIN, &    *
      *              NON-BLOOD DEDUCTIBLE CALCS.                    *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) =
                    ' G' OR ' K' OR ' R' OR ' U' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 14550-CALC-GJK
                         THRU 14550-CALC-GJK-EXIT

                      IF PKG-BLD-DED-LINE
                         NEXT SENTENCE
                      END-IF

                      IF PTRADIO-LINE-FLAG = 'Y' AND
                         H-NUCMED-TOT-OFFSET > 0 THEN
                         PERFORM 14550-PTRADIO-OFFSET
                            THRU 14550-PTRADIO-OFFSET-EXIT
                      END-IF

                      IF PTCA-LINE-FLAG = 'Y' AND
                         W-PTCA-DAY-MAX > 0 AND
                         W-CAPROC-MAX > 0 THEN
                         PERFORM 14550-PTCA-OFFSET
                            THRU 14550-PTCA-OFFSET-EXIT
                      END-IF

                      PERFORM 14560-CALC-BENE-DEDUCT
                         THRU 14560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 14550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      * 11/12/2008 - BRACHYTHERAPY SOURCE'S STATUS INDICATOR = ' U' *
      *              EFFECTIVE 1/1/2009                             *
      *                                                             *
      * 11/16/2009 - REMOVED LOGIC FOR THERAPEUTIC RADIOPHARMS &    *
      *              BRACHYTHERAPY SOURCES B/C THESE ARE NOT PAID   *
      *              AT COST FOR CY 2010                            *
      *                                                             *
      * 04/11/2011 - ADDED LOGIC TO PREVENT LINES WITH PAFS 9 OR 10 *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      * 05/13/2016 - ADDED LOGIC FOR BLOOD DEDUCTIBLE LINES ON A    *
      *              COMPREHENSIVE APC CLAIM (ZERO OUT REIM, COIN,  *
      *              & NON-BLOOD DEDUCTIBLE)                        *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * FOR BLOOD DEDUCTIBLE LINES ON A COMPREHENSIVE APC CLAIM:    *
      * SET REIMBURSEMENT, COINSURANCE, & DEDUCTIBLE AMOUNTS TO $0  *
      *-------------------------------------------------------------*
             IF PKG-BLD-DED-LINE
                MOVE 0 TO H-LITEM-REIM
                          H-TOTAL-LN-DEDUCT
                          H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 14550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE REIMBURSEMENT AND SET COINSURANCE AMOUNTS TO $0   *
      * FOR LINES WITH A PAF= 9 OR 10                               *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 9' OR '10')
                COMPUTE H-LITEM-REIM ROUNDED =
                   H-LITEM-PYMT - H-TOTAL-LN-DEDUCT
                MOVE 0 TO H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 14550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                  H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX).


      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DRUGS, DEVICES, BRACHYTHERAPY, THERAP. RADIO, & BLOOD       *
      * (SI = G AND H LINES HAVE A MIN-COIN = 0, WON'T ENTER LOGIC) *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) =
                  ' G' OR ' H' OR ' K' OR ' R' OR ' U'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       14550-CALC-STANDARD-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *                    DEVICE CREDIT PROCESSING                 *
      *                                                             *
      ***************************************************************
      *                                                             *
      * SEARCH THE DEVICE CREDIT TABLE TO SEE IF THERE IS A LINE    *
      * APC MATCH; IF SO, REDUCE THE PYMT BY THE LESSER OF THE      *
      * LINE'S PORTION OF THE DEVICE CREDIT AMOUNT OR THE LINE'S    *
      * APC CAP.                                                    *
      *                                                             *
      *    * BE SURE TO UPDATE THE TABLE REFERENCES EACH YEAR *     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/18/2013 - DEVICE CREDIT LOGIC NEW FOR CY 2014, REPLACES  *
      *              DEVICE REDUCTION LOGIC                         *
      *                                                             *
      ***************************************************************
       14550-DEVICE-CREDIT.

           SEARCH ALL DEV-CR15
              AT END
                 GO TO 14550-DEVICE-CREDIT-EXIT
              WHEN DEV-APC15 (DEV-INDX15) = OPPS-APC (LN-SUB)
                 PERFORM 14550-DEVICE-COMPUTE
                    THRU 14550-DEVICE-COMPUTE-EXIT.

       14550-DEVICE-CREDIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IF THE LINE APC IS FOUND IN THE DEVICE CREDIT TABLE,        *
      * DETERMINE HOW MUCH THE LINE DEVICE CREDIT SHOULD BE.        *
      *                                                             *
      *    * BE SURE TO UPDATE THE TABLE REFERENCES EACH YEAR *     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/18/2013 - DEVICE CREDIT LOGIC NEW FOR CY 2014, REPLACES  *
      *              DEVICE REDUCTION LOGIC                         *
      * 01/27/2014 - LOGIC REVISED TO NO LONGER SUBTRACT THE DEVICE *
      *              CREDIT BEFORE PAYMENT ADJUSTENTS ARE MADE.     *
      *              THE CREDIT IS NOW SUBTRACTED FROM THE TOTAL    *
      *              PAYMENT (ADJUSTMENTS ALREADY APPLIED) IN       *
      *              PARAGRAPH 14550-SCH-ADJ.                       *
      *                                                             *
      ***************************************************************
       14550-DEVICE-COMPUTE.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE CREDIT (FD)*
      *-------------------------------------------------------------*
           IF H-TOT-DEVCR-PYMTS > 0
              COMPUTE H-LINE-DEVCR-PYMT-RATE ROUNDED =
                      W-APC-PYMT (W-LP-INDX) / H-TOT-DEVCR-PYMTS
              COMPUTE H-LINE-DEVCR-AMT ROUNDED =
                      L-DEVICE-CREDIT * H-LINE-DEVCR-PYMT-RATE
           ELSE
              MOVE 0 TO H-LINE-DEVCR-PYMT-RATE
              MOVE 0 TO H-LINE-DEVCR-AMT
           END-IF.

      *-------------------------------------------------------------*
      * CAP THE LINE'S DEVICE CREDIT AT THE UNADJUSTED DEVICE       *
      * CREDIT CAP AMOUNT                                           *
      *-------------------------------------------------------------*
           IF DEV-CAP15 (DEV-INDX15) < H-LINE-DEVCR-AMT
              MOVE DEV-CAP15 (DEV-INDX15) TO H-LINE-DEVCR-AMT
           END-IF.
       14550-DEVICE-COMPUTE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *        FOR LINES WITH A SI OF S, V, T, P, X, R, OR U        *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA MUST BE A  *
      *   VALUE OF '   01' THRU '   99' AND THE L-PSF-PROV-TYPE     *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2009: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      * 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES (SI=R)     *
      *              ADDED TO LOGIC.  BRACHY LINES NOT PROCESSED IN *
      *              PARAGRAPH & NOW HAVE A SI = U, SI = K LOGIC    *
      *              REMOVED FROM THIS PARAGRAPH.                   *
      * 05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD    *
      *              DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.     *
      *              FIX EFFECTIVE RETROACTIVE TO 01/01/2009.       *
      * 11/17/2009 - BRACHYTHERAPY LINES NOW PROCESSED IN THIS      *
      *              PARAGRAPH FOR CY 2010 (SI=U), DO NOT RECEIVE   *
      *              WAGE ADJUSTMENT                                *
      * 05/09/2011 - REVISED LOGIC TO EXCLUDE BILL TYPE 14X FROM    *
      *              RECEIVING THE SCH ADD-ON                       *
      * 02/07/2012 - REPLACE BILL14X-FLAG WITH CONDITION NAME       *
      *              BILL-TYPE-14X                                  *
      * 01/27/2014 - WHEN APPLICABLE, SUBTRACT DEVICE CREDIT        *
      *              AMOUNT FROM LINE ITEM PAYMENT                  *
      *                                                             *
      ***************************************************************
       14550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      ***************************************************************

             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22') AND
                 (NOT BILL-TYPE-14X))
      *          (BILL14X-FLAG = 'N'))

      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      ***************************************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = R (BLOOD) OR U (BRACHY) LINES ARE NOT WAGE-ADJUSTED    *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U'
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.

      *-------------------------------------------------------------*
      * REDUCE PAYMENT BY DEVICE CREDIT IF APPLICABLE               *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR 'J1') AND
                 H-LINE-DEVCR-AMT > 0)
                 IF H-LITEM-PYMT >= H-LINE-DEVCR-AMT
                    COMPUTE H-LITEM-PYMT ROUNDED =
                            H-LITEM-PYMT - H-LINE-DEVCR-AMT
                 ELSE
                    MOVE 0 TO H-LITEM-PYMT
                 END-IF
             END-IF.

       14550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *         SET PARTIAL HOSPITALIZATION (PHP) "CAP" APC         *
      *             FOR USE IN THE OUTLIER CALCULATION              *
      *                  (FOR SI = P LINES ONLY)                    *
      *                                                             *
      *       ** ASK POLICY FOR THE PHP "CAP" APC ANUALLY **        *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/13/2008 - THIS PARAGRAPH IS NEW FOR CY 2009,             *
      *              CY 2009 PHP "CAP" APC = 0173                   *
      * 11/15/2010 - MODIFIED LOGIC TO ASSIGN CMHCS APC 00173 &     *
      *              HOSPITALS APC 00176                            *
      * 11/04/2011 - MODIFIED LOGIC TO STOP APPLYING APC 00176      *
      *              CAP TO PHP HOSPITAL LINES                      *
      *                                                             *
      ***************************************************************
       14550-PHP-PMT-FOR-OUTL.

      *-------------------------------------------------------------*
      *  ** FOR CMHC CLAIMS ONLY - USE APC 00173                    *
      *  LOOK-UP PHP "CAP" APC IN THE APC TABLE, STARTING AT        *
      *  THE APC'S MOST CURRENT RECORD - RETRIEVE PAYMENT RATE      *
      *-------------------------------------------------------------*
             IF (L-PSF-PROV-3456 >= '1400' AND
                 L-PSF-PROV-3456 <= '1499') OR
                (L-PSF-PROV-3456 >= '4600' AND
                 L-PSF-PROV-3456 <= '4799') OR
                (L-PSF-PROV-3456 >= '4900' AND
                 L-PSF-PROV-3456 <= '4999')
              SEARCH ALL WAA-ENTRY
                AT END
                   GO TO 14550-PHP-PMT-FOR-OUTL-EXIT

                WHEN WAA-APC (WAA-INDX) = '00173'
                   MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                   PERFORM 14550-PHP-APC-LOOKUP.
      *-------------------------------------------------------------*
      * REDUCE APC PMT RATE BY REDUCED UPDATE RATIO WHEN APPROPRIATE*
      * 11/13/2009 - NEW FOR CY 2009                                *
      *-------------------------------------------------------------*
             PERFORM 14180-REDUCE-APC-PYMT
                THRU 14180-REDUCE-APC-PYMT-EXIT.

      *-------------------------------------------------------------*
      * APPLY THE SCH ADJUSTMENT TO APC RATE WHEN APPLICABLE        *
      * CY 2009 ADJ = 7.1%                                          *
      *-------------------------------------------------------------*
             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))
                     COMPUTE H-APC-PYMT ROUNDED =
                         (H-APC-PYMT * 1.071)
             END-IF.

      *-------------------------------------------------------------*
      *  CALCULATE THE PHP "CAP" APC'S LINE PAYMENT (INCLUDES       *
      *  WAGE ADJUSTMENT AND SCH ADJUSTMENT IF APPLICABLE)          *
      *-------------------------------------------------------------*
             COMPUTE H-PHP-LITEM-PYMT-OUTL ROUNDED =
                       (((H-APC-PYMT * .60) *
                            W-WINX (W-LP-INDX)) +
                         (H-APC-PYMT * .40)) *
                       W-SRVC-UNITS (W-LP-INDX) *
                       W-DISC-RATE (W-LP-INDX).

       14550-PHP-PMT-FOR-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            LOOK-UP PHP "CAP" APC IN THE APC TABLE           *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/13/2008 - THIS PARAGRAPH IS NEW FOR CY 2009              *
      *                                                             *
      ***************************************************************
       14550-PHP-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE ZEROS TO H-APC-PYMT

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 14550-PHP-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT.

       14550-PHP-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = G, K, R, & U LINES:  *
      *   - APC PAYMENT FOR BLOOD LINES (SI = R)                    *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = G, K, OR U LINES (DRUGS,     *
      *     BIOLOGICALS, RADIOPHARMS, & BRACHYTHERAPIES)            *
      *   - SCH ADJUSTMENT APPLIED TO BLOOD & BRACHY LINES          *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      * - 11/12/2008 - FOR CY 2009, BRACHYS NOT PROCESSED IN THIS   *
      *   PARAGRAPH; BRACHY LINES ASSIGNED A NEW SI OF ' U'         *
      * - 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES HAVE A   *
      *   SI = R                                                    *
      * - 12/05/2008 - MODIFIED LOGIC TO SEND BLOOD LINES WITHOUT   *
      *   A PMT ADJ FLAG = 5 OR 6 TO THE SCH ADJUSTMENT PARAGRAPH,  *
      *   INCLUDED SI = R IN THE BLOOD IDENTIFICATION LOGIC         *
      * - 11/15/2009 - BRACHYTHERPY SERVICES (SI = U) & THERAPEUTIC *
      *   RADIOPHARMS (SI = K) SENT TO THIS PARAGRAPH FOR CY 2010,  *
      *   LOGIC ALTERED TO PROCESS SI = U (RECEIVE REGULAR APC PMT) *
      * - 11/17/2009 - SEND BRACHYTHERAPY LINES TO 10550-SCH-ADJ TO *
      *   MAKE ELIGIBLE FOR SCH ADJUSTMENT, NOT WAGE ADJUSTED       *
      * - 05/10/2016 - ADDED LOGIC FOR SPECIAL HANDLING OF BLOOD    *
      *   DEDUCTIBLE LINES ON CLAIMS WITH A COMPREHENSIVE APC       *
      *                                                             *
      ***************************************************************
       14550-CALC-GJK.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 14550-SET-BLOOD-FRACTION
                     THRU 14550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 14550-ADJ-BLOOD-COST
                     THRU 14550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 14550-SCH-ADJ
                     THRU 14550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * CHANGE THE PAYMENT OF THE BLOOD DEDUCTIBLE LINE ON THE SAME *
      * CLAIM AS A COMPREHENSIVE APC TO THE BLOOD DEDUCTIBLE AMOUNT *
      *-------------------------------------------------------------*
                  IF PKG-BLD-DED-LINE
                      MOVE H-LN-BLOOD-DEDUCT TO H-LITEM-PYMT
                  END-IF

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE, BUT PAF = 5 OR 6           *
      * (BLOOD PROCESSING AND PRODUCT BILLED TOGETHER)              *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 14550-ADJ-PLATE-COST
                      THRU 14550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 14550-SCH-ADJ
                      THRU 14550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE AND PAF NOT EQUAL TO 5 OR 6 *
      * (ONLY BLOOD PRODUCT BILLED)                                 *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 12/05/2008 - 7550-SCH-ADJ PERFORM ADDED FOR BLOOD LINES     *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 14550-SCH-ADJ
                      THRU 14550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      *    CALCULATE LINE ITEM PAYMENT FOR DRUGS, BIOLOGICALS,      *
      *    BRACHYTHERAPY SERVICES, & THERAPEUTIC RADIOPHARMS        *
      *                                                             *
      ***************************************************************
                ELSE
                   IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                      COMPUTE H-LITEM-PYMT ROUNDED =
                       W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                        * W-DISC-RATE (W-LP-INDX)
                   ELSE
                      IF OPPS-SRVC-IND (LN-SUB) = ' U'
                         PERFORM 14550-SCH-ADJ
                            THRU 14550-SCH-ADJ-EXIT
                      END-IF
                   END-IF
                END-IF
             END-IF
             END-IF.

       14550-CALC-GJK-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       14550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       14550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       14550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       14550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       14550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       14550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      ADJUST THE PASS-THROUGH RADIOPHARM PAYMENT BY          *
      *      ITS PROPORTION OF THE NUCLEAR MEDICINE OFFSET          *
      *                                                             *
      *      EFFECTIVE 04/01/2009, LOGIC ADDED 02/11/2009           *
      *                                                             *
      ***************************************************************
       14550-PTRADIO-OFFSET.

      *-------------------------------------------------------------*
      * CALCULATE PROPORTION OF TOTAL OFFSET TO BE APPLIED TO LINE  *
      *-------------------------------------------------------------*
      * 12/20/2009 - ADDED LOGIC TO PREVENT DIVISION BY ZERO ERROR  *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             IF H-PTRADIO-TOT-CHRGS > 0 THEN
                COMPUTE W-PTRADIO-CHRG-RATE ROUNDED =
                        H-SUB-CHRG / H-PTRADIO-TOT-CHRGS
             ELSE
                MOVE 0 TO W-PTRADIO-CHRG-RATE
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE APPLIED TO LINE           *
      *-------------------------------------------------------------*
             COMPUTE W-PTRADIO-LINE-OFFSET ROUNDED =
                     H-NUCMED-TOT-OFFSET * W-PTRADIO-CHRG-RATE.

      *-------------------------------------------------------------*
      * SUBTRACT THE APPLICABLE OFFSET FROM THE LINE PAYMENT        *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-PYMT ROUNDED =
                     H-LITEM-PYMT - W-PTRADIO-LINE-OFFSET.

       14550-PTRADIO-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      ADJUST THE PASS-THROUGH CONTRAST AGENT PAYMENT BY      *
      *   ITS PROPORTION OF THE PT CONTRAST AGENT PROCEDURE OFFSET  *
      *                                                             *
      *      EFFECTIVE 01/01/2010, LOGIC ADDED 11/16/2009           *
      *                                                             *
      ***************************************************************
       14550-PTCA-OFFSET.

      *-------------------------------------------------------------*
      * CAPTURE LINE DATE OF SERVICE                                *
      *-------------------------------------------------------------*
             MOVE OPPS-LITEM-DOS (LN-SUB) TO W-CAPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT CONTRAST AGENT DAY TABLE FOR DATE OF SERVICE      *
      *-------------------------------------------------------------*
             SET W-PTCA-DAY-INDX TO 1.

             SEARCH W-PTCA-DAY-ENTRY

      *-------------------------------------------------------------*
      * DATE OF SERVICE NOT FOUND IN TABLE, STOP PROCESS            *
      *-------------------------------------------------------------*
                AT END
                   GO TO 14550-PTCA-OFFSET-EXIT

      *-------------------------------------------------------------*
      * DATE OF SERVICE FOUND IN TABLE, TAKE OFFSET                 *
      *-------------------------------------------------------------*
                WHEN W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX) =
                     W-CAPROC-SRVC-DATE

      *-------------------------------------------------------------*
      * CALCULATE PROPORTION OF TOTAL OFFSET TO BE APPLIED TO LINE  *
      *-------------------------------------------------------------*
      * 12/20/2009 - ADDED LOGIC TO PREVENT DIVISION BY ZERO ERROR  *
      *-------------------------------------------------------------*
                     MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                     IF W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX) > 0
                        COMPUTE W-PTCA-CHRG-RATE ROUNDED =
                                H-SUB-CHRG /
                                W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX)
                     ELSE
                        MOVE 0 TO W-PTCA-CHRG-RATE
                     END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE APPLIED TO LINE           *
      *-------------------------------------------------------------*
                     COMPUTE W-PTCA-LINE-OFFSET ROUNDED =
                         W-PTCA-DAY-TOT-OFFSET (W-PTCA-DAY-INDX) *
                         W-PTCA-CHRG-RATE

      *-------------------------------------------------------------*
      * SUBTRACT THE APPLICABLE OFFSET FROM THE LINE PAYMENT        *
      *-------------------------------------------------------------*
                     IF H-LITEM-PYMT >= W-PTCA-LINE-OFFSET
                        COMPUTE H-LITEM-PYMT ROUNDED =
                                H-LITEM-PYMT - W-PTCA-LINE-OFFSET
                     ELSE
                        MOVE 0 TO H-LITEM-PYMT
                     END-IF
             END-SEARCH.

       14550-PTCA-OFFSET-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *           CALCULATE PAYMENT FOR PAID AT COST LINES          *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 08-11-2010 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED       *
      *                                                             *
      ***************************************************************
       14555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST - "PAID AT COST"         *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).

      *-------------------------------------------------------------*
      * SEARCH THE PTDO HCPCS TABLE FOR THE CURRENT LINE HCPCS,     *
      * IF FOUND APPLY THE OFFSET                                   *
      *-------------------------------------------------------------*
              SET W-PTDO-HCPCS-INDX TO 1.
              SEARCH W-PTDO-HCPCS-ENTRY

                 AT END
                    CONTINUE

                 WHEN W-PTDO-HCPCS-HCPCS (W-PTDO-HCPCS-INDX) =
                        OPPS-HCPCS (LN-SUB) AND
                      W-PTDO-HCPCS-LNSUB (W-PTDO-HCPCS-INDX) =
                        LN-SUB
                      PERFORM 14556-CALC-PTDO-OFFSET
                         THRU 14556-CALC-PTDO-OFFSET-EXIT.

      *-------------------------------------------------------------*
      * CAPTURE PAYMENT AMOUNT                                      *
      *-------------------------------------------------------------*
             IF T-LITEM-PYMT < 0 THEN
                MOVE 0 TO H-LITEM-PYMT
             ELSE
                MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

      *-------------------------------------------------------------*
      * UPDATE PASS-THROUGH DEVICE TABLE WITH LINE ITEM PAYMENT OF  *
      * DEVICE LINE (CHARGES CONVERTED TO COST LESS APPLICABLE      *
      * OFFSET AMOUNT)                                              *
      * WHEN PTD-FLAG = 'Y', A PASS-THROUGH DEVICE IS ON THE CLAIM  *
      *-------------------------------------------------------------*
      * 11/16/2009   REMOVED LOGIC THAT EXCLUDES THERAP. RADIOS     *
      *              (THERAP. RADIOS DO NOT HAVE AN SI=H CY 2010)   *
      *-------------------------------------------------------------*
             IF PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' H'
                  PERFORM 14557-LOAD-PTD-LINE-PYMT
                     THRU 14557-LOAD-PTD-LINE-PYMT-EXIT
             END-IF.

       14555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *   REDUCE LINE ITEM PAYMENTS OF PASS-THROUGH DEVICES THAT    *
      * HAVE AN ASSOCIATED PROCEDURE ON THE CLAIM BY THE PROCEDURE  *
      *                WAGE-ADJUSTED OFFSET AMOUNT                  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ** EFFECTIVE 10/01/2010 - REVISED PT DEVICE OFFSET LOGIC    *
      *                                                             *
      ***************************************************************
       14556-CALC-PTDO-OFFSET.

      *-------------------------------------------------------------*
      * SEARCH PTDO PROCEDURE TABLE FOR THE PT DEVICE HCPCS LINE    *
      *-------------------------------------------------------------*
             SET W-PTDO-PROC-INDX TO 1.
             SEARCH W-PTDO-PROC-ENTRY

                AT END
                   GO TO 14556-CALC-PTDO-OFFSET-EXIT

      *-------------------------------------------------------------*
      * CURRENT PT DEVICE LINE'S ASSOCIATED PROCEDURE FOUND         *
      *-------------------------------------------------------------*
                WHEN W-PTDO-PROC-APC (W-PTDO-PROC-INDX) =
                       W-PTDO-HCPCS-PROC-APC (W-PTDO-HCPCS-INDX) AND
                     W-PTDO-PROC-LNSUB (W-PTDO-PROC-INDX) =
                       W-PTDO-HCPCS-PROC-LNSUB (W-PTDO-HCPCS-INDX)

      *-------------------------------------------------------------*
      * DETERMINE HOW MANY PROCEDURE UNITS WILL BE ALLOCATED        *
      *-------------------------------------------------------------*
                   IF W-PTDO-PROC-UNITS (W-PTDO-PROC-INDX) <=
                      W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX)
                      MOVE W-PTDO-PROC-UNITS (W-PTDO-PROC-INDX) TO
                           W-DOPROC-UNITS
                   ELSE
                      MOVE W-PTDO-PROC-TOT-DUNITS (W-PTDO-PROC-INDX) TO
                           W-DOPROC-UNITS
                   END-IF

      *-------------------------------------------------------------*
      * DETERMINE WHAT % OF THE OFFSET WILL BE APPLIED              *
      *-------------------------------------------------------------*
                   IF W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX) > 0
                      COMPUTE W-PTDO-CHRG-RATE ROUNDED =
                           W-PTDO-HCPCS-SUB-CHRG (W-PTDO-HCPCS-INDX) /
                           W-PTDO-PROC-TOT-DCHRGS (W-PTDO-PROC-INDX)
                   ELSE
                      GO TO 14556-CALC-PTDO-OFFSET-EXIT
                   END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE TAKEN                     *
      *-------------------------------------------------------------*
                   COMPUTE W-PTDO-LINE-OFFSET ROUNDED =
                           W-PTDO-CHRG-RATE *
                           W-DOPROC-UNITS *
                           W-PTDO-PROC-WA-OFFSET (W-PTDO-PROC-INDX)

      *-------------------------------------------------------------*
      * SUBTRACT THE OFFSET AMOUNT FROM THE LINE PAYMENT            *
      *-------------------------------------------------------------*
                   IF W-PTDO-LINE-OFFSET <= T-LITEM-PYMT
                      COMPUTE T-LITEM-PYMT ROUNDED =
                              T-LITEM-PYMT - W-PTDO-LINE-OFFSET
                   ELSE
                      MOVE 0 TO T-LITEM-PYMT
                   END-IF.


       14556-CALC-PTDO-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH CHARGES FOR THE      *
      *  DEVICE LINE (LINE ITEM PAYMENT LESS OFFSET CONVERTED TO    *
      *  CHARGES)                                                   *
      *  (FOR ASSOCIATED PROCEDURE OUTLIER CALCULATION)             *
      *                                                             *
      ***************************************************************
       14557-LOAD-PTD-LINE-PYMT.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR THE RECORD THAT   *
      * CORRESPONDS TO THE CURRENT SERVICE LINE                     *
      *-------------------------------------------------------------*
             SET W-PTD-INDX TO 1.
             SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS NOT        *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   GO TO 14557-LOAD-PTD-LINE-PYMT-EXIT

      *-------------------------------------------------------------*
      * IF THE LINE'S HCPCS IS IN THE TABLE, CALCULATE THE LINE'S   *
      * CHARGES AND PLACE INTO TABLE (FOR H LINES, THE PAYMENT IS   *
      * CONVERTED TO COST AND OFFSET.  HERE, THE PAYMENT IS         *
      * CONVERTED BACK INTO CHARGES BY DIVIDING IT BY THE COST TO   *
      * CHARGE RATIO.)                                              *
      *-------------------------------------------------------------*
                WHEN  W-PTD-SUB (W-PTD-INDX) = LN-SUB
                      MOVE H-LITEM-PYMT TO W-PTD-LITEM-PYMT (W-PTD-INDX)

             END-SEARCH.

       14557-LOAD-PTD-LINE-PYMT-EXIT.
            EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       14560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * LINES INELIGIBLE FOR DEDUCTIBLE SKIP DEDUCTIBLE CALCULATION *
      * EFF. 7/1/2009 - CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      * ASSIGNED A PAF = ' 4'                                       *
      * - 04/11/2011 - ADDED PAF 9 FOR SERVICES WHERE THE           *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *   (ADDED FOR PREVENTIVE SERVICES WAIVER IN CY 2011)         *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 4' OR ' 9')
                GO TO 14560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       14560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      * - 11/12/2008: FOR CY 2009, BRACHYS SI = U AND BLOOD SI = R  *
      *   BRACHY INELIGIBLE FOR OUTLIER, BLOOD ELIGIBLE FOR OUTLIER *
      *                                                             *
      * - 12/05/2008: ADDED SI = K TO LIST OF SIS INELIGIBLE FOR    *
      *   OUTLIER (BRACHYS & BLOOD NO LONGER HAVE SI = K)           *
      *                                                             *
      * - 11/17/2009: REMOVED U FROM LIST OF SIS INELIGIBLE FOR     *
      *   OUTLIER; BRACHYS NOW ELIGIBLE B/C NOT PAID AT COST CY 2010*
      *                                                             *
      * - 12/16/2009: ADDED SIS R AND U TO LOGIC THAT DISTRIBUTES   *
      *   PACKAGED CHARGES TO PAYABLE LINES. V2010.1.2              *
      *                                                             *
      * - 11/04/2011: MODIFIED LOGIC TO APPLY THE PHP CAP ONLY TO   *
      *   PHP CMHC LINES, NOT PHP HOSPITAL LINES PER POLICY'S       *
      *   INSTRUCTIONS                                              *
      *                                                             *
      * - 05/10/2016: ADDED LOGIC TO EXCLUDE LINES ELIGIBLE FOR THE *
      *   BLOOD DEDUCTIBLE AND ON A CLAIM WITH A COMPREHENSIVE APC  *
      *   FROM THE OUTLIER PAYMENT                                  *
      *                                                             *
      ***************************************************************
       14600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * LINES WITH SERVICE INDICATORS NOT ELIGIBLE FOR AN OUTLIER   *
      * PAYMENT AND LINES PACKAGED AS PART OF DRUG ADMINISTRATION   *
      * APC PAYMENT BYPASS OUTLIER CALCULATION                      *
      * (DRUGS, DEVICES, PACKAGED SERVICES, BIOLOGICALS)            *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW THAT DISTRIBUTES PACKAGED *** *
      * *** CHARGES TO PAYABLE LINES AND IN THE SUMMING LOGIC   *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * 11/12/2008 - BRACHY (SI=U) ADDED TO LIST                    *
      * 12/05/2008 - SI K ADDED TO THE LIST                         *
      * 11/16/2009 - REMOVED PAF=2 FROM BRACHY (SI=U) CRITERIA      *
      * 11/17/2009 - REMOVE SI=U, BRACHYS ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR ' N' OR
                                          ' K') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4')
                   GO TO 14600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * BLOOD LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND ON A      *
      * CLAIM WITH A COMPREHENSIVE APC NOT ELIGIBLE FOR OUTLIER     *
      *-------------------------------------------------------------*
      * 05/10/2016 - NEW FOR JULY 2016                              *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  GO TO 14600-ADJ-CHRG-OUTL-EXIT
             END-IF.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                             ' X' OR ' P' OR ' R' OR
                                             ' U' OR 'J1') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                            ' X' OR ' P' OR ' R' OR
                                            ' U' OR 'J1') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A COMPOSITE ADJ.     *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 01 - NN...) ARE ACCUMULATED BY COMPOSITE            *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME        *
      * (PAYABLE) LINE'S CHARGES.                                   *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2007 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      * 11/12/2008 - CHANGED LOGIC TO USE THE COMPOSITE ADJUSTMENT  *
      *              FLAG INSTEAD OF THE PAYMENT ADJUSTMENT FLAG    *
      *              VALUES 91 - 99 TO ID PRIME COMPOSITE LINES     *
      ***************************************************************

      *-------------------------------------------------------------*
      * COMPOSITE ADJUSTMENT FLAG > 0 INDICATES COMPOSITE APC       *
      *-------------------------------------------------------------*
           IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = '00'

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.


      ***************************************************************
      *   CALCULATE TOTAL MENTAL HEALTH CHARGES FOR APC 34 LINES    *
      *                                                             *
      * THE CHARGES OF PACKAGED LINES WITH A PACKAGING FLAG OF '2'  *
      * ON A CLAIM WITH APC 34 (MENTAL HEALTH APC) ARE ACCUMULATED  *
      * AND ADDED TO THE SEPARATELY PAYABLE APC 34 LINE'S CHARGES.  *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 11/12/2008 - LOGIC DISABLED FOR CY 2009 BECAUSE MENTAL      *
      *              HEALTH COMPOSITES ARE NOW PROCESSED THE SAME   *
      *              AS ALL OTHER COMPOSITES USING THE COMPOSITE    *
      *              ADJUSTMENT FLAG                                *
      ***************************************************************
      *    IF APC34-FLAG = 'Y' AND OPPS-APC (LN-SUB) = '0034'
      *       COMPUTE W-SUB-CHRG (W-LP-INDX) =
      *               W-SUB-CHRG (W-LP-INDX) +
      *               H-TOT-MH-CHRG
      *    END-IF.


      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD BECAUSE PAYMENTS MAY BE  *
      *   ADJUSTED FOR PASS-THROUGH DEVICES - ADDED 02/14/2008      *
      *   NEW FOR CY 2009 - ALWAYS USE THE PHP "CAP" APC'S WAGE ADJ *
      *   PMT FOR PHP LINES (SI=P)                                  *
      *-------------------------------------------------------------*
      * 11/04/2011 - ONLY APPLY PHP "CAP" TO CMHC LINES; PER        *
      *              POLICY'S INSTRUCTIONS PHP HOSPITAL LINES ARE   *
      *              NOT CAPPED.                                    *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           IF OPPS-SRVC-IND (LN-SUB) = ' P' AND
              ( (L-PSF-PROV-3456 >= '1400' AND
                 L-PSF-PROV-3456 <= '1499') OR
                (L-PSF-PROV-3456 >= '4600' AND
                 L-PSF-PROV-3456 <= '4799') OR
                (L-PSF-PROV-3456 >= '4900' AND
                 L-PSF-PROV-3456 <= '4999') )
              MOVE H-PHP-LITEM-PYMT-OUTL TO H-LITEM-PYMT-OUTL
           ELSE
              MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL
           END-IF.


      ***************************************************************
      *   CALCULATE TOTAL CHARGES AND PAYMENTS FOR PROCEDURE LINES  *
      *             ELIGIBLE FOR PASS-THROUGH DEVICE(S)             *
      *                                                             *
      * THE CHARGES AND LINE PAYMENTS OF PASS-THROUGH DEVICE LINES  *
      * ARE ADDED TO THE CHARGES AND PAYMENTS OF ALL PROCEDURES     *
      * ELIGIBLE TO BE BILLED WITH THE PASS-THROUGH DEVICE.         *
      * (PTD-FLAG = 'Y' INDICATES THERE IS AT LEAST ONE             *
      *  PASS-THROUGH DEVICE ON THE CLAIM)                          *
      *-------------------------------------------------------------*
      * 02/12/2008 - LOGIC ADDED FOR CY 2008 QTR 2                  *
      ***************************************************************
           IF (PTD-FLAG = 'Y') AND
              (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR ' X'
               OR 'J1')

      *-------------------------------------------------------------*
      * DETERMINE WHETHER THE LINE IS ELIGIBLE FOR A PT DEVICE      *
      *-------------------------------------------------------------*
              PERFORM 14670-SET-PTD-PROC-FLAG
                 THRU 14670-SET-PTD-PROC-FLAG-EXIT

      *-------------------------------------------------------------*
      * PROCEDURE IS ELIGIBLE FOR A PASS-THROUGH DEVICE             *
      *-------------------------------------------------------------*
      * 11/12/2008 - EDITED TO LOOK AT PTD-PROC-FLAG, NOT PTD-FLAG  *
      *              NO HARM DONE USING THE PTD-FLAG PREVIOUSLY     *
      *-------------------------------------------------------------*
              IF PTD-PROC-FLAG = 'Y'

      *-------------------------------------------------------------*
      * LOOP THROUGH ELIGIBLE PROCEDURE'S PASS-THROUGH DEVICE TABLE *
      * GET THE PASS-THROUGH DEVICE HCPCS(S) FOR WHICH THE          *
      * PROCEDURE IS ELIGIBLE & UPDATE PROCEDURE CHARGES & PAYMENTS *
      *-------------------------------------------------------------*
                 PERFORM 14610-PERFORM-SEARCH
                    THRU 14610-PERFORM-SEARCH-EXIT
                    VARYING W-PTD-PROC-SUB FROM 1 BY 1
                    UNTIL W-PTD-PROC-SUB > W-PTD-CNT
              END-IF
           END-IF.


      ***************************************************************
      *                                                             *
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      * -NEW FOR JANUARY 2009                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE PHP "CAP" APC'S LINE PAYMENT                        *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      * (CMHC PROVIDERS ONLY PROCESS PARTIAL HOSPITALIZATION LINES) *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT


      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE

                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 2775)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT
                  END-IF

               END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       14600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  SEARCH THE PASS-THROUGH DEVICE TABLE FOR THE PASS-THROUGH  *
      *           DEVICE(S) THE PROCEDURE IS ELIGIBLE FOR           *
      *                                                             *
      ***************************************************************
       14610-PERFORM-SEARCH.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR ALL OCCURANCES    *
      * OF THE PASS-THRU DEVICE HCPCS IN THE PASS-THRU DEVICE TABLE.*
      * THIS IS DONE FOR ALL PASS-THROUGH DEVICES THE PROCEDURE IS  *
      * ELIGIBLE FOR.                                               *
      *-------------------------------------------------------------*
           MOVE 'N' TO W-END-OF-PTD-TBL.

           IF W-PTD-PROC-HCPCS (W-PTD-PROC-SUB) NOT = '     '
              SET W-PTD-INDX TO 1
              PERFORM 14611-SEARCH-PTD-HCPCS
                 THRU 14611-SEARCH-PTD-HCPCS-EXIT
                UNTIL W-END-OF-PTD-TBL = 'Y'
           END-IF.

       14610-PERFORM-SEARCH-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE & UPDATE PROCEDURE LINE PAYMENTS   *
      *                         AND CHARGES                         *
      *                                                             *
      ***************************************************************
       14611-SEARCH-PTD-HCPCS.

           MOVE 'N' TO W-END-OF-PTD-TBL.

      *-------------------------------------------------------------*
      * SEARCH PASS-THROUGH DEVICE TABLE                            *
      *-------------------------------------------------------------*
           SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THERE ARE NO MORE OCCURANCES OF THE PASS-THROUGH DEVICE, *
      * STOP THE SEARCH AND INDICATE END OF FILE                    *
      *-------------------------------------------------------------*
                AT END
                   MOVE 'Y' TO W-END-OF-PTD-TBL
                   GO TO 14611-SEARCH-PTD-HCPCS-EXIT

      *-------------------------------------------------------------*
      * IF THE PASS-THROUGH DEVICE IS FOUND, INDICATE NOT END OF    *
      * FILE AND UPDATE THE PROCEDURE'S CHARGES AND PAYMENTS        *
      *-------------------------------------------------------------*
                WHEN  W-PTD-HCPCS (W-PTD-INDX) =
                      W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)

                      MOVE 'N' TO W-END-OF-PTD-TBL

                      PERFORM 14612-UPDATE-PTD-PROC
                         THRU 14612-UPDATE-PTD-PROC-EXIT

                      SET W-PTD-INDX UP BY 1

             END-SEARCH.

      *-------------------------------------------------------------*
      * SET UP FOR NEXT PASS-THROUGH DEVICE RECORD                  *
      *-------------------------------------------------------------*
             MOVE ZEROS TO H-PTD-UNIT-RATE
                           H-PTD-SUB-CHRG
                           H-PTD-LITEM-PYMT.

       14611-SEARCH-PTD-HCPCS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE PROCEDURE LINE'S PAYMENTS AND CHARGES WITH THE   *
      * PASS-THROUGH DEVICE'S PAYMENTS AND CHARGES (IN PROPORTION   *
      * TO THE PROCEDURE'S UNITS IF OTHER PROCEDURES ARE ELIGIBLE   *
      *            FOR THE PASS-THROUGH DEVICE AS WELL)             *
      *                                                             *
      ***************************************************************
       14612-UPDATE-PTD-PROC.

      *-------------------------------------------------------------*
      * DETERMINE PROPORTION OF CHARGES & PAYMENTS PROCEDURE LINE   *
      * WILL RECEIVE BASED ON ITS NUMBER OF UNITS                   *
      *-------------------------------------------------------------*
           IF W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX) NOT = 0
              COMPUTE H-PTD-UNIT-RATE ROUNDED =
                      OPPS-SRVC-UNITS (LN-SUB) /
                      W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX)
           ELSE
              MOVE 0 TO H-PTD-UNIT-RATE
           END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE AMOUNT OF PASS-THROUGH DEVICE CHARGES TO BE   *
      * ADDED TO THE PROCEDURE'S CHARGES IN PROPORTION TO UNITS     *
      *-------------------------------------------------------------*
           COMPUTE H-PTD-SUB-CHRG ROUNDED =
                   W-PTD-SUB-CHRG (W-PTD-INDX) *
                   H-PTD-UNIT-RATE.

      *-------------------------------------------------------------*
      * ADD PASS-THROUGH DEVICE CHARGES TO PROCEDURE LINE CHARGES   *
      *-------------------------------------------------------------*
           COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                   W-SUB-CHRG (W-LP-INDX) +
                   H-PTD-SUB-CHRG.

      *-------------------------------------------------------------*
      * CALCULATE THE AMOUNT OF PASS-THROUGH DEVICE PAYMENTS TO BE  *
      * ADDED TO THE PROCEDURE'S PAYMENTS IN PROPORTION TO UNITS    *
      *-------------------------------------------------------------*
           COMPUTE H-PTD-LITEM-PYMT ROUNDED =
                   W-PTD-LITEM-PYMT (W-PTD-INDX) *
                   H-PTD-UNIT-RATE.

      *-------------------------------------------------------------*
      * ADD PASS-THROUGH DEVICE PAYMENT TO PROCEDURE LINE PAYMENT   *
      *-------------------------------------------------------------*
           COMPUTE H-LITEM-PYMT-OUTL ROUNDED =
                   H-LITEM-PYMT-OUTL +
                   H-PTD-LITEM-PYMT.


       14612-UPDATE-PTD-PROC-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 14550-CALC-GJK &       *
      *      14550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES        *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       14655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9056' OR
                                    'P9021' OR
                                    'P9051' OR
                                    'P9016' OR
                                    'P9038' OR
                                    'P9010' OR
                                    'P9054' OR
                                    'P9058' OR
                                    'P9040' OR
                                    'P9022' OR
                                    'P9057' OR
                                    'P9039'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       14655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A PASS-THROUGH      *
      *  DEVICE HCPCS (FOR OUTLIER PAYMENT ADJ)                     *
      *    - IF SO, SET PTD-LINE-FLAG = 'Y'                         *
      *    - THIS FLAG IS USED IN THE PASS-THROUGH DEVICE LOGIC     *
      *      TO POPULATE THE PASS-THROUGH-DEVICE TABLE              *
      *  ** UPDATE THIS LIST EVERY QUARTER                          *
      *  (CODE NEW FOR CY2008 QTR 2; ADDED 02/11/2008)              *
      *                                                             *
      ***************************************************************
       14665-SET-PTD-LINE-FLAG.

           MOVE 'N' TO PTD-LINE-FLAG.

      ***********************************************************
      * 11/12/2008 - ALL LOGIC DISABLED B/C THERE ARE NO        *
      *              NO PASS-THROUGH DEVICES FOR CY 2009        *
      * 11/18/2009 - NO PASS-THROUGH DEVICES FOR CY 2010        *
      * 08/12/2010 - NEW PT DEVICE EFFECTIVE OCTOBER 1, 2010    *
      * 08/15/2011 - NEW PT DEVICES EFFECTIVE OCTOBER 1, 2011   *
      * 11/04/2011 - NEW PT DEVICES EFFECTIVE JANUARY 1, 2012   *
      * 11/07/2011 - UPDATED LOGIC FOR CY 2013                  *
      * 07/30/2013 - UPDATED LOGIC FOR CY 2013 + HCPC C1841     *
      * 11/14/2014 - UPDATED LOGIC FOR CY 2015 + C1841 & C2624  *
      * 05/13/2015 - UPDATED LOGIC FOR 3Q 2015 + C2623 & C2613  *
      ***********************************************************

      *---------------------------------------------------------*
      * ONLY CLAIMS WITH A DATE OF SERVICE ON OR AFTER          *
      * 10/01/2010 ARE ELIGIBLE                                 *
      *---------------------------------------------------------*
           IF OPPS-LITEM-DOS (LN-SUB) >= 20101001

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 10/01/2011       *
      *---------------------------------------------------------*
              IF (OPPS-LITEM-DOS (LN-SUB) >= 20111001 AND
                  OPPS-HCPCS (LN-SUB) = ('C1830' OR
                                         'C1840') ) OR

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 01/01/2012       *
      *---------------------------------------------------------*
                 (OPPS-LITEM-DOS (LN-SUB) >= 20120101 AND
                  OPPS-HCPCS (LN-SUB) = ('C1840' OR
                                         'C1886') ) OR

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 10/01/2013       *
      *---------------------------------------------------------*
                  (OPPS-LITEM-DOS (LN-SUB) >= 20131001 AND
                  OPPS-HCPCS (LN-SUB) = 'C1841') OR

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 01/01/2015       *
      *---------------------------------------------------------*
                 (OPPS-LITEM-DOS (LN-SUB) >= 20150101 AND
                  OPPS-HCPCS (LN-SUB) = ('C1841' OR
                                         'C2624')) OR

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 04/01/2015       *
      *---------------------------------------------------------*
                 (OPPS-LITEM-DOS (LN-SUB) >= 20150401 AND
                  OPPS-HCPCS (LN-SUB) = 'C2623') OR

      *---------------------------------------------------------*
      * PT DEVICE HCPCS EFFECTIVE ON AND AFTER 07/01/2015       *
      *---------------------------------------------------------*
                 (OPPS-LITEM-DOS (LN-SUB) >= 20150701 AND
                  OPPS-HCPCS (LN-SUB) = 'C2613')

                 MOVE 'Y' TO PTD-LINE-FLAG
              END-IF
           END-IF.

       14665-SET-PTD-LINE-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A PROCEDURE         *
      *  ELIGIBLE FOR A PASS-THROUGH DEVICE (FOR OUTLIER PMT ADJ)   *
      *    - IF SO, SET PTD-PROC-FLAG = 'Y'                         *
      *    - THIS FLAG IS USED IN THE PASS-THROUGH DEVICE LOGIC     *
      *  ** UPDATE THIS LIST EVERY QUARTER                          *
      *  (CODE NEW FOR CY2008 QTR 2; ADDED 02/11/2008)              *
      *                                                             *
      ***************************************************************
       14670-SET-PTD-PROC-FLAG.

           MOVE 'N' TO PTD-PROC-FLAG.

      ***********************************************************
      * 11/12/2008 - ALL LOGIC DISABLED B/C THERE ARE NO        *
      *              NO PASS-THROUGH DEVICES FOR CY 2009        *
      * 11/18/2009 - NO PASS-THROUGH DEVICES FOR CY 2010        *
      * 08/12/2010 - NEW PT DEVICE EFFECTIVE OCTOBER 1, 2010    *
      * 08/15/2011 - NEW PT DEVICES EFFECTIVE OCTOBER 1, 2011   *
      * 11/04/2011 - NEW PT DEVICES EFFECTIVE JANUARY 1, 2012,  *
      *              AND ONE PAIRING TERMINATED 12/31/2011      *
      * 11/07/2012 - NEW PT PAIRINGS EFFECTIVE JANUARY 1, 2013, *
      *              AND THREE  PAIRINGS TERMINATED IN 2012     *
      *              THERE ARE THREE VALID PT DEVICES FOR 2013  *
      * 07/30/2013 - NEW PT PAIRING EFFECTIVE OCTOBER 1, 2013,  *
      *              THERE ARE FOUR VALID PT DEVICES FOR 2013   *
      * 11/14/2014 - NEW PT PAIRING EFFECTIVE JANUARY 1, 2015,  *
      *              THERE ARE FIVE VALID PT DEVICES FOR 2015   *
      * 05/13/2015 - NEW PT PAIRING EFFECTIVE APRIL   1, 2015,  *
      *              THERE ARE SIX  VALID PT DEVICES FOR 2015   *
      * 05/13/2015 - NEW PT PAIRING EFFECTIVE JULY    1, 2015,  *
      *              THERE ARE (7)  VALID PT DEVICES FOR 2015   *
      ***********************************************************

      *---------------------------------------------------------*
      * ONLY CLAIMS WITH A DATE OF SERVICE ON OR AFTER          *
      * 10/01/2010 ARE ELIGIBLE                                 *
      * WHEN POLICY WENT INTO EFFECT - DO NOT CHANGE            *
      *---------------------------------------------------------*
           IF OPPS-LITEM-DOS (LN-SUB) >= 20101001

      *---------------------------------------------------------*
      *  SPECIFY NUMBER OF ENTRIES (# OF PT DEVICES FROM POLICY)*
      *---------------------------------------------------------*
              MOVE 7 TO W-PTD-CNT

      *---------------------------------------------------------*
      *  INITIALIZE PROCEDURE'S PTD HCPCS TABLE TO SPACES       *
      *---------------------------------------------------------*
              PERFORM VARYING W-PTD-PROC-SUB FROM 1 BY 1
                UNTIL W-PTD-PROC-SUB > W-PTD-CNT
                   MOVE SPACES TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-PERFORM


      ***********************************************************
      *                                                         *
      *      ** PT DEVICE MAPPINGS VALID DURING CY 2015 **      *
      *                                                         *
      ***********************************************************


      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 10/01/2011    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 1 (C1830)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20111001 AND
                 OPPS-HCPCS (LN-SUB) = ('38220' OR
                                        '38221')

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 1       TO W-PTD-PROC-SUB
                 MOVE 'C1830' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF


      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 01/01/2012    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 2 (C1840)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20120701 AND
                 OPPS-HCPCS (LN-SUB) = ('0308T')

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 2       TO W-PTD-PROC-SUB
                 MOVE 'C1840' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF


      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 01/01/2013    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 3 (C1886)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20130101 AND
                 OPPS-HCPCS (LN-SUB) = ('31660' OR
                                        '31661')

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 3       TO W-PTD-PROC-SUB
                 MOVE 'C1886' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF

      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 10/01/2013    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 4 (C1841)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20131001 AND
                 OPPS-HCPCS (LN-SUB) = '0100T'

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 4       TO W-PTD-PROC-SUB
                 MOVE 'C1841' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF

      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 01/01/2015    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 5 (C2624)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20150101 AND
                 OPPS-HCPCS (LN-SUB) = 'C9741'

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 5       TO W-PTD-PROC-SUB
                 MOVE 'C2624' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF

      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 04/01/2015    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 6 (C2623)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20150401 AND
                 OPPS-HCPCS (LN-SUB) = ('37224' OR '37226' OR
                                        '37227')
                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 6       TO W-PTD-PROC-SUB
                 MOVE 'C2623' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF

      ***********************************************************
      * PT DEVICE MAPPINGS EFFECTIVE ON AND AFTER 07/01/2015    *
      ***********************************************************

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 7 (C2613)  *
      *---------------------------------------------------------*
              IF OPPS-LITEM-DOS (LN-SUB) >= 20150701 AND
                 OPPS-HCPCS (LN-SUB) = '32405'

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 7       TO W-PTD-PROC-SUB
                 MOVE 'C2613' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF

      *---------------------------------------------------------*
      * END OF PT DEVICE MAPPINGS VALID DURING CY 2015 FOR      *
      * LINES SERVICED ON OR AFTER 10/01/2010                   *
      *---------------------------------------------------------*
           END-IF.

       14670-SET-PTD-PROC-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE LINE HCPCS IS A CURRENT PASS-THROUGH *
      *                 RADIOPHARMACEUTICAL HCPCS                   *
      *                                                             *
      *    - IF SO: SET PTRADIO-LINE-FLAG = 'Y',                    *
      *             ADD 1 TO COUNT OF TOTAL PT RADIOPHARMS,         *
      *             ADD CHARGES TO CLAIM TOTAL PT RADIOPHARM CHRGES *
      *    - THIS FLAG IS USED IN PARAGRAPHS 14125-INIT &           *
      *      14550-CALC-STANDARD TO PROCESS PT RADIOPHARM LINES     *
      *                                                             *
      *  ** PASS-THROUGH RADOIOPHARM TABLE IS UPDATED QUARTERLY     *
      *  (CODE NEW FOR CY2009; ADDED 02/10/2009)                    *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      *  12/20/2011 - LOGIC REVISED TO INCLUDE TERMINATION DATE     *
      *               AS A VALID DATE OF SERVICE                    *
      *                                                             *
      ***************************************************************
       14680-SET-PTRADIO-LINE-FLAG.

           MOVE 'N' TO PTRADIO-LINE-FLAG.

           SEARCH ALL PTRH-ENTRY
            AT END
             MOVE 'N' TO PTRADIO-LINE-FLAG

            WHEN PTRH-PTRADIO-HCPCS (PTRH-INDX) = OPPS-HCPCS (LN-SUB)
             IF OPPS-LITEM-DOS (LN-SUB) >= PTRH-EFF-DATE (PTRH-INDX) AND
               (OPPS-LITEM-DOS (LN-SUB) <= PTRH-TERM-DATE (PTRH-INDX) OR
                PTRH-TERM-DATE (PTRH-INDX) = 0) THEN
                MOVE 'Y' TO PTRADIO-LINE-FLAG
             END-IF.

       14680-SET-PTRADIO-LINE-FL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE LINE HCPCS IS A CURRENT PASS-THROUGH *
      *                     CONTRAST AGENT HCPCS                    *
      *                                                             *
      *    - IF SO: SET PTCA-LINE-FLAG = 'Y',                       *
      *    - THIS FLAG IS USED IN PARAGRAPHS 14125-INIT &           *
      *      14550-CALC-STANDARD TO PROCESS PT CONTRAST AGENT LINES *
      *                                                             *
      *  ** PASS-THROUGH CONTRAST AGENT TABLE IS UPDATED QUARTERLY  *
      *  (CODE NEW FOR CY2010; ADDED 11/16/2009)                    *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      *  12/20/2011 - LOGIC REVISED TO INCLUDE TERMINATION DATE     *
      *               AS A VALID DATE OF SERVICE                    *
      *                                                             *
      ***************************************************************
       14681-SET-PTCA-LINE-FLAG.

           MOVE 'N' TO PTCA-LINE-FLAG.

           SEARCH ALL PTCH-ENTRY
            AT END
             MOVE 'N' TO PTCA-LINE-FLAG

            WHEN PTCH-PTCONTR-HCPCS (PTCH-INDX) = OPPS-HCPCS (LN-SUB)
             IF OPPS-LITEM-DOS (LN-SUB) >= PTCH-EFF-DATE (PTCH-INDX) AND
               (OPPS-LITEM-DOS (LN-SUB) <= PTCH-TERM-DATE (PTCH-INDX) OR
                PTCH-TERM-DATE (PTCH-INDX) = 0) THEN
                MOVE 'Y' TO PTCA-LINE-FLAG
             END-IF.

       14681-SET-PTCA-LINE-FL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE LINE HCPCS IS A CURRENT PASS-THROUGH *
      *                   DEVICE HCPCS (FOR OFFSET)                 *
      *                                                             *
      *    - IF SO: SET PTDO-LINE-FLAG = 'Y',                       *
      *    - THIS FLAG IS USED IN PARAGRAPHS 14125-INIT &           *
      *      14550-CALC-STANDARD TO PROCESS PT DEVICE LINES         *
      *                                                             *
      *  ** PASS-THROUGH DEVICE OFFSET TABLE IS UPDATED QUARTERLY   *
      *  (CODE NEW FOR OCT 2010; ADDED 08/02/2010)                  *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 12/20/2011 - LOGIC REVISED TO ACCOMMODATE DEVICES THAT HAVE *
      *              MULTIPLE PROCEDURE PAIRINGS WITH DIFFERENT     *
      *              EFFECTIVE AND TERMINATION DATES.  ALSO ENSURED *
      *              THE TERMINATION DATE IS AFTER OR ON THE        *
      *              DATE OF SERVICE.                               *
      *                                                             *
      ***************************************************************
       14682-SET-PTDO-LINE-FLAG.

           MOVE 'N' TO PTDO-LINE-FLAG.
           SET PTDO-INDX TO 1.

           SEARCH PTDO-ENTRY
            AT END
             MOVE 'N' TO PTDO-LINE-FLAG

      *----------------------------------------------------------------*
      * LINE HCPCS IS FOUND IN THE PT DEVICE OFFSET HISTORY TABLE AND  *
      * THE DATE OF SERVICE IS WITHIN THE EFFECTIVE & TERMINATION DATE *
      * PARAMETERS.                                                    *
      *----------------------------------------------------------------*
            WHEN PTDO-DEV-HCPCS (PTDO-INDX) = OPPS-HCPCS (LN-SUB) AND
                PTDO-EFF-DATE (PTDO-INDX) <= OPPS-LITEM-DOS (LN-SUB) AND
               (PTDO-TERM-DATE (PTDO-INDX) >= OPPS-LITEM-DOS (LN-SUB) OR
                PTDO-TERM-DATE (PTDO-INDX) = 0)
                MOVE 'Y' TO PTDO-LINE-FLAG.

       14682-SET-PTDO-LINE-FL-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *            PROCESS DRUG COINSURANCE TABLE RECORDS           *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE "DRUG" LINE COINSURANCE WHEN THE PROCEDURE      *
      *  COINSURANCE AMOUNTS PLUS THE "DRUG" COINSURANCE AMOUNT(S)  *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       14800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 14810-PROCESS-TYPE1
                   THRU 14810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 14840-PROCESS-TYPE2
                   THRU 14840-PROCESS-TYPE2-EXIT.

       14800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH "DRUG" COINSURANCE, DETERMINE THE *
      *  % OF TOTAL "DRUG" COINSURANCE THAT CAN BE PAID IN ADDITION *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE DRUG COINSURANCE CAN BE PAID *
      *  WHEN H-RATIO = 1, ALL OF THE DRUG COINSURANCE CAN BE PAID  *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       14810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * DRUGS WERE ADMINISTERED ON THE DAY                          *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & WAGE ADJUSTED COINSURANCE OF THE      *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL DRUG COIN THAT CAN BE    *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S DRUG COIN CAN BE PAID B/C THE PROCEDURE/  *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL DRUG COINSURANCE CAN BE PAID WITHIN THE     *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       14810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE "DRUG" LINE'S NATIONAL COINSURANCE AMOUNT AND   *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       14840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 DRUG COIN REC HAS SAME DATE OF SERVICE AS    *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE DRUG COIN RECORD *
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE DRUG LINE BY   *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD DRUG COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT    *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       14840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       14900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       14900-END-PRICE-RTN-EXIT.
           EXIT.




      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 15000 FOR CALENDAR YEAR 2016 PROCESSING        **
      **          SERVICE FROM DATES: 1/1/2016 - 12/31/2016           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE OCE)       *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ACCUMULATE PACKAGED MENTAL HEALTH CHARGES                  *
      *  7. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  8. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  9. CALCULATE SERVICE LINE PAYMENTS                            *
      * 10. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 11. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 12. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 13. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 14. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, AND COMPOSITE *
      *     CHARGES OF APPLICABLE PROCEDURES.                          *
      *     ALL ADJUSTMENTS ARE DONE FOR OUTLIER DETERMINATION ONLY.   *
      * 15. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 16. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR DRUG LINES;  *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE DRUG LINE'S REIMBURSEMENT                     *
      * 17. ACCUMULATE CLAIM TOTALS                                    *
      * 18. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       15000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY),  *
      *            DETERMINE CLAIM DEVICE CREDIT AMOUNT               *
      *            (CLAIM LEVEL INITIALIZATION)                       *
      *                                                               *
      *****************************************************************
              PERFORM 15100-INIT
                 THRU 15100-INIT-EXIT.
      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - PHP-APC-FLAG - PARTIAL HOSPITALIZATION CLAIM              *
      *     (APCS 00172, 00173, 00175, & 00176)                       *
      *   - PTRADIO-CLAIM-FLAG - PASS-THROUGH RADIOPAHARM(S) ON CLAIM *
      *   - PTCA-CLAIM-FLAG - PASS-THROUGH CONTRAST AGENT ON CLAIM    *
      *     CREATE PASS-THROUGH CONTRAST AGENT DAY TABLE              *
      *   - C-APC-CLAIM-FLAG - COMPREHENSIVE APC ON CLAIM - FOR       *
      *     SPECIAL BLOOD DEDUCTIBLE LINE LOGIC                       *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY PASS-THROUGH CONTRAST AGENT DAY TABLE FOR CLAIM  *
      *--------------------------------------------------------*
              MOVE 0 TO W-PTCA-DAY-MAX.

              PERFORM 15125-INIT
                 THRU 15125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.


      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH *
      *            RADIOPHARMACEUTICAL OFFSET, CREATE CONTRAST        *
      *            AGENT PROCEDURE TABLE FOR PASS-THROUGH CONTRAST    *
      *            AGENT OFFSET.                                      *
      *            (LOOP THROUGH THE CLAIM LINES)                     *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY TABLES FOR NEW CLAIM                             *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX    W-BLD-MAX    W-CMP-MAX
                        W-NUCMED-MAX W-CAPROC-MAX.

              PERFORM 15150-INIT
                 THRU 15150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      *--------------------------------------------------------*
      * CALCULATE TOTAL OFFSET AMT FOR PT RADIOPHARM LINE(S)   *
      * (# OF UNITS SUMMED LIMITED TO THE LESSER OF THE # OF   *
      *  PT RADIOPHARM HCPCS & THE # OF NUCLEAR MEDICINE UNITS)*
      *--------------------------------------------------------*
              IF W-NUCMED-MAX > 0
                 SET W-NUCMED-INDX TO 1
                 PERFORM UNTIL (W-NUCMED-INDX > W-NUCMED-MAX) OR
                               (W-NUCMED-INDX > H-PTRADIO-HCPCS-CNT)
                    COMPUTE H-NUCMED-TOT-OFFSET ROUNDED =
                            H-NUCMED-TOT-OFFSET +
                            W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX)
                    SET W-NUCMED-INDX UP BY 1
                 END-PERFORM
              END-IF.

      *--------------------------------------------------------*
      * CALCULATE TOTAL OFFSET AMT PER DAY FOR PT CONTRAST     *
      * AGENT LINE(S) (# OF UNITS SUMMED LIMITED TO THE LESSER *
      * OF THE # OF PT CONTRAST AGENT HCPCS & THE # OF PT      *
      * CONTRAST AGENT PROCEDURE APC UNITS PER DAY)            *
      *--------------------------------------------------------*
              IF W-PTCA-DAY-MAX > 0 AND W-CAPROC-MAX > 0
                 SET W-PTCA-DAY-INDX TO 1
                 PERFORM UNTIL (W-PTCA-DAY-INDX > W-PTCA-DAY-MAX)
                    PERFORM 15396-TOTAL-DAY-PTCA-OFFS
                       THRU 15396-TOTAL-DAY-PTCA-OFFS-EXIT
                    SET W-PTCA-DAY-INDX UP BY 1
                 END-PERFORM
              END-IF.

      *-------------------------------------------------------------*
      * CALCULATE WAGE-ADJUSTED PASS-THROUGH DEVICE OFFSETS         *
      * (VALUE CODES QN, QO & QP; CLAIM LEVEL)                      *
      * NEW FOR CY2016 - 11/13/2015                                 *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QN > 0
                COMPUTE H-QN-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QN * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QN * .40)
             END-IF.

             IF L-PAYER-ONLY-VC-QO > 0
                COMPUTE H-QO-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QO * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QO * .40)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF L-PAYER-ONLY-VC-QP > 0
      *         COMPUTE H-QP-WA-PTD-OFFSET ROUNDED =
      *                 ((L-PAYER-ONLY-VC-QP * .60) * H-WINX) +
      *                 (L-PAYER-ONLY-VC-QP * .40)
      *      END-IF.


      *****************************************************************
      *                                                               *
      *   STEP 4 - INITIALIZE W-DCP-MAX                               *
      *   ------                                                      *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, AND MOVE LINE ITEM         *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 15400-CALCULATE
                 THRU 15400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, AND COMPOSITES, AND CALCULATE  *
      *            OUTLIER PAYMENTS                                   *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 15600-ADJ-CHRG-OUTL
                 THRU 15600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


      *****************************************************************
      *                                                               *
      *   STEP 7 - CALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS  *
      *   ------   FOR STATUS INDICATOR G & K LINES.  THE DAILY INPA- *
      *            TIENT COINSURANCE LIMIT IS APPLIED USING THE WAGE  *
      *            ADJUSTED COINSURANCE OF EACH DAY'S MOST EXPENSIVE  *
      *            PROCEDURE OR VISIT.                                *
      *            (LOOP THROUGH THE DRUG COINSURANCE TABLE)          *
      *                                                               *
      *****************************************************************
                IF GJK-FLAG = 'Y'
                   PERFORM 15800-ADJ-STV-REIM
                      THRU 15800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                END-IF.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 15900-END-PRICE-RTN
                 THRU 15900-END-PRICE-RTN-EXIT.

       15000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY COINSURANCE LIMIT (H-IP-LIMIT)         *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       15100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE FLAGS AND VARIABLES               *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 11/03/2008 - APC33-FLAG REPLACED BY PHP-APC-FLAG            *
      * 11/12/2008 - BRACHY-APC-FLAG REMOVED, NOT USED FOR CY 2009  *
      * 02/09/2009 - PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG ADDED    *
      * 11/16/2009 - RADIOPH-APC-FLAG REMOVED; PTCA-CLAIM-FLAG,     *
      *              PTCA-LINE FLAG ADDED                           *
      * 02/07/2012 - BILL14X-FLAG REMOVED                           *
      * 11/18/2013 - DEVCR-CLAIM-FLAG ADDED                         *
      * 11/17/2015 - REMOVED APC34-FLAG (MENTAL HEALTH), PTD-FLAG,  *
      *              PTD-LINE-FLAG, PTD-PROC-FLAG, AND              *
      *              C1820-OFFSET-FLAG BECAUSE THEY'RE NOT USED     *
      * 02/09/2016 - ADD LOGIC TO DETERMINE CLAIM'S DEVICE CREDIT   *
      * 02/10/2016 - DEVCR-CLAIM-FLAG REMOVED (NO LONGER USED)      *
      *-------------------------------------------------------------*
             MOVE 'N'   TO PHP-APC-FLAG
                           GJK-FLAG
                           ST0-FLAG
                           N-FLAG
                           PHP-HCPCS-FLAG
                           MH-HCPCS-FLAG
                           BLD-DEDUC-HCPCS-FLAG
                           PTRADIO-CLAIM-FLAG
                           PTRADIO-LINE-FLAG
                           PTCA-CLAIM-FLAG
                           PTCA-LINE-FLAG
                           C-APC-CLAIM-FLAG
                           PKG-BLD-DED-LINE-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO  TO A-OUTLIER-PYMT
                           A-TOTAL-CLM-DEDUCT
                           A-TOT-CLM-CHRG
                           A-TOT-CLM-PYMT
                           A-BLOOD-DEDUCT-DUE
                           A-BLOOD-PINTS-USED
                           A-WINX
                           W-LNC-MAX
                           A-DEVICE-CREDIT-QD.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.

      *-------------------------------------------------------------*
      * INITIATILIZE WORKING STORAGE DATES - 10-23-2014             *
      *-------------------------------------------------------------*
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-BEGIN-YYYY.
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-END-YYYY.
      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 15100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 15100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 15100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION15 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE THE TOTAL DEVICE CREDIT AMOUNT TO BE DEDUCTED     *
      * FROM THE CLAIM - USE THE LESSER OF THE AMOUNT IN            *
      * VALUE CODE FD AND THE CAP AMOUNT IN VALUE CODE QU           *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QU > 0 AND
                L-DEVICE-CREDIT > 0
                IF L-PAYER-ONLY-VC-QU < L-DEVICE-CREDIT
                   MOVE L-PAYER-ONLY-VC-QU TO H-CLAIM-DEVCR-AMT
                ELSE
                   MOVE L-DEVICE-CREDIT TO H-CLAIM-DEVCR-AMT
                END-IF
             END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
      *-------------------------------------------------------------*
      *   USE SPECIAL WAGE INDEX WHEN INDICATED                     *
      *   (PSF RECORD EFFECTIVE DATE MUST BE WITHIN THE CLAIM'S CY) *
      *   ADDED 10-23-2014 FOR CY 2015                              *
      *-------------------------------------------------------------*
                   IF (L-PSF-SPEC-PYMT-IND = '1' OR '2') AND
                      (L-PSF-EFFDT >= W-CY-BEGIN-DATE AND
                       L-PSF-EFFDT <= W-CY-END-DATE)
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX
                      MOVE 1288 TO H-IP-LIMIT
                      GO TO 15100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 15100-INIT-EXIT.
             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 15100-INIT-EXIT.
             MOVE 1288 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      * APPLY WAGE INDEX FLOOR POLICY                               *
      * (USE HIGHER OF CBSA WAGE INDEX AND STATE RURAL WAGE INDEX)  *
      *-------------------------------------------------------------*
      * 10-23-2014 - NEW FLOOR LOGIC FOR CY 2015                    *
      * 10-28-2015 - NEW STATE CODES ADDED FOR APRIL 2016           *
      *-------------------------------------------------------------*

      *-------------------------------------------------------------*
      * >FIRST, CONFIRM FLOOR SWITCH IS SET                         *
      *-------------------------------------------------------------*
             SET W-FLOOR-LOOKUP TO TRUE.

      *-------------------------------------------------------------*
      * >GET PROVIDER'S STATE CODE FOR RURAL FLOOR WAGE INDEX       *
      *  LOOK-UP (NEW FOR JULY 2016)                                *
      *-------------------------------------------------------------*
             MOVE L-PSF-STATE-CODE TO W-PSF-PROV-ST.

      *-------------------------------------------------------------*
      * >CHECK FOR EXTENDED STATE CODES AND SET TO BASE STATE CODE  *
      *  FOR FLOOR STATE CODE LOOKUP.                               *
      *  ** REPLACED WITH THE CODE ABOVE FOR JULY 2016              *
      *-------------------------------------------------------------*
      *      MOVE L-PSF-PROV-ST TO W-PSF-PROV-ST.
      *
      *     **TEXAS**
      *      IF W-PSF-PROV-ST = '67' OR '74' OR '97'
      *         MOVE '45' TO W-PSF-PROV-ST.
      *     **FLORIDA**
      *      IF W-PSF-PROV-ST = '68' OR '69'
      *         MOVE '10' TO W-PSF-PROV-ST.
      *     **KANSAS**
      *      IF W-PSF-PROV-ST = '70'
      *         MOVE '17' TO W-PSF-PROV-ST.
      *     **LOUISIANA**
      *      IF W-PSF-PROV-ST = '71' OR '95'
      *         MOVE '19' TO W-PSF-PROV-ST.
      *     **OHIO**
      *      IF W-PSF-PROV-ST = '72'
      *         MOVE '36' TO W-PSF-PROV-ST.
      *     **PENNSYLVANIA**
      *      IF W-PSF-PROV-ST = '73'
      *         MOVE '39' TO W-PSF-PROV-ST.
      *     **CALIFORNIA**
      *      IF W-PSF-PROV-ST = '55' OR '75' OR '92'
      *         MOVE '05' TO W-PSF-PROV-ST.
      *     **IOWA**
      *      IF W-PSF-PROV-ST = '76'
      *         MOVE '16' TO W-PSF-PROV-ST.
      *     **MINNESOTA**
      *      IF W-PSF-PROV-ST = '77'
      *         MOVE '24' TO W-PSF-PROV-ST.
      *     **ILLINOIS**
      *      IF W-PSF-PROV-ST = '78'
      *         MOVE '14' TO W-PSF-PROV-ST.
      *     **MARYLAND**
      *      IF W-PSF-PROV-ST = '80'
      *         MOVE '21' TO W-PSF-PROV-ST.
      *     **CONNECTICUT**
      *      IF W-PSF-PROV-ST = '81'
      *         MOVE '07' TO W-PSF-PROV-ST.
      *     **MASSACHUSETTS**
      *      IF W-PSF-PROV-ST = '82'
      *         MOVE '22' TO W-PSF-PROV-ST.
      *     **NEW JERSEY**
      *      IF W-PSF-PROV-ST = '83'
      *         MOVE '31' TO W-PSF-PROV-ST.
      *     **PUERTO RICO**
      *      IF W-PSF-PROV-ST = '84'
      *         MOVE '40' TO W-PSF-PROV-ST.
      *     **GEORGIA**
      *      IF W-PSF-PROV-ST = '85'
      *         MOVE '11' TO W-PSF-PROV-ST.
      *     **NORTH CAROLINA**
      *      IF W-PSF-PROV-ST = '86'
      *         MOVE '34' TO W-PSF-PROV-ST.
      *     **SOUTH CAROLINA**
      *      IF W-PSF-PROV-ST = '87'
      *         MOVE '42' TO W-PSF-PROV-ST.
      *     **TENNESSEE**
      *      IF W-PSF-PROV-ST = '88'
      *         MOVE '44' TO W-PSF-PROV-ST.
      *     **ARKANSAS**
      *      IF W-PSF-PROV-ST = '89'
      *         MOVE '04' TO W-PSF-PROV-ST.
      *     **OKLAHOMA**
      *      IF W-PSF-PROV-ST = '90'
      *         MOVE '37' TO W-PSF-PROV-ST.
      *     **COLORADO**
      *      IF W-PSF-PROV-ST = '91'
      *         MOVE '06' TO W-PSF-PROV-ST.
      *     **OREGON**
      *      IF W-PSF-PROV-ST = '93'
      *         MOVE '38' TO W-PSF-PROV-ST.
      *     **WASHINGTON**
      *      IF W-PSF-PROV-ST = '94'
      *         MOVE '50' TO W-PSF-PROV-ST.
      *     **NEW MEXICO**
      *      IF W-PSF-PROV-ST = '96'
      *         MOVE '32' TO W-PSF-PROV-ST.
      *-------------------------------------------------------------*
      * >NOW, CALL WAGE INDEX LOOKUP AND LOOK FOR THE STATE FLOOR.  *
      *  STORE PSF-CBSA IN A-CBSA (IT GETS MOVED THERE IN THE NEXT  *
      *  STEP ANYWAY). THIS FREES H-PSF-CSBA FOR THE FLOOR SEARCH   *
      *  MOVE THREE SPACES + STATE CODE TO H-PSF-CBSA               *
      *  STORE RESULT IN H-WINX.                                    *
      *  MOVE A-CBSA BACK TO H-PSF-CBSA FOR CLEANUP                 *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             STRING '   ' DELIMITED BY SIZE
                   W-PSF-PROV-ST DELIMITED BY SIZE
                   INTO H-PSF-CBSA.
             PERFORM 15200-CALC-WAGEINDX
                THRU 15200-CALC-WAGEINDX-EXIT.
             MOVE A-CBSA TO H-PSF-CBSA.

      *-------------------------------------------------------------*
      * >GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN   *
      *  BY THE PSF SPECIAL WAGE INDEX VALUE)                       *
      *                                                             *
      *   NOTE: IF PSF SPECIAL WAGE INDEX VALUE USED,               *
      *         15100-INIT-EXIT WILL BE CALLED ABOVE - THIS CODE    *
      *         WILL NEVER BE REACHED. THEREFORE CHECKING FOR A 0   *
      *         VALUE SHOULD BE UNNECESSARY.                        *
      * >SET WAGE INDEX LOOKUP FLAG (FLOOR FLAG = 'N')              *
      *-------------------------------------------------------------*
             SET W-WINX-LOOKUP TO TRUE.
                PERFORM 15200-CALC-WAGEINDX
                   THRU 15200-CALC-WAGEINDX-EXIT.
       15100-INIT-EXIT.
           EXIT.





      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND AN APC / HCPCS      *
      *                                                             *
      *  - SET FLAG IF APC = 5851/5852/5861/5862 (PARTIAL HOSP.)    *
      *  - SET FLAG IF PASS-THROUGH RADIOPHARMS(S) ON CLAIM         *
      *    (NEW FOR APRIL CY 2009 - ADDED 02/10/2009)               *
      *  - SET FLAG IF PASS-THROUGH CONTRAST AGENT(S) ON CLAIM      *
      *    (NEW FOR JANUARY CY 2010 - ADDED 11/15/2009)             *
      *  - SET FLAG IF CLAIM IS ELIGIBLE FOR DEVICE CREDIT          *
      *    (NEW FOR JANUARY CY 2014)                                *
      *  - SET FLAG IF CLAIM HAS A COMPREHENSIVE APC (C-APC) LINE   *
      *    (NEW FOR JULY 2016)                                      *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION HCPCS FROM     *
      *              0033 TO 0172 & 0173 FOR CY 2009                *
      *                                                             *
      * 11/12/2008 - HCPCS C1820 EXPIRED FROM PASS-THROUGH STATUS   *
      *              DECEMBER 2007, OFFSET FLAG LOGIC DISABLED      *
      *                                                             *
      * 08/02/2010 - ADDED LOGIC TO SET PASS-THOUGH DEVICE FLAG FOR *
      *              DEVICE OFFSETS AND POPULATE THE CORRESPONDING  *
      *              TABLE                                          *
      *                                                             *
      * 11/15/2010 - ADDED APCS 0175 & 0176 TO LIST OF PHP APCS     *
      *                                                             *
      * 11/18/2013 - ADDED LOGIC TO SET DEVICE CREDIT CLAIM FLAG    *
      *                                                             *
      * 11/17/2015 - REMOVED LOGIC TO SET FLAGS FOR PASS-THROUGH    *
      *              DEVICES (FOR OUTLIER & OFFSET LOGIC)           *
      *            - UPDATED PHP APCS FOR 2016                      *
      *            - REMOVED APC34-FLAG (MENTAL HEALTH) - NOT USED  *
      *            - REMOVED APC 0339 UNITS OVERRIDE                *
      *                                                             *
      * 05/09/2016 - ADDED LOGIC TO SET COMPREHENSIVE APC CLAIM FLAG*
      *                                                             *
      ***************************************************************
       15125-INIT.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A PHP APC (PARTIAL HOSP)*
      *-------------------------------------------------------------*
             IF OPPS-APC (LN-SUB) = '5851' OR
                OPPS-APC (LN-SUB) = '5852' OR
                OPPS-APC (LN-SUB) = '5861' OR
                OPPS-APC (LN-SUB) = '5862'
                MOVE 'Y' TO PHP-APC-FLAG.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE IS PASS-THROUGH RADIOPHARM  *
      * AND ACCUMULATE TOTAL PT RADIOPHARM LINES & CHARGES          *
      *-------------------------------------------------------------*
             PERFORM 15680-SET-PTRADIO-LINE-FLAG
                THRU 15680-SET-PTRADIO-LINE-FL-EXIT.

             IF PTRADIO-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTRADIO-CLAIM-FLAG
                ADD 1 TO H-PTRADIO-HCPCS-CNT
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-PTRADIO-TOT-CHRGS ROUNDED =
                        H-PTRADIO-TOT-CHRGS + H-SUB-CHRG
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE IS A PASS-THROUGH CONTRAST  *
      * AGENT AND ACCUMULATE TOTAL PT CONTRAST AGENT LINES &        *
      * CHARGES, SUM BY LINE ITEM DATE OF SERVICE, & CREATE A       *
      * RECORD FOR EACH DAY IN THE PASS-THROUGH CONTRAST AGENT      *
      * DAY TABLE                                                   *
      *-------------------------------------------------------------*
             PERFORM 15681-SET-PTCA-LINE-FLAG
                THRU 15681-SET-PTCA-LINE-FL-EXIT.

             IF PTCA-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTCA-CLAIM-FLAG
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                PERFORM 15130-LOAD-PTCA-DAY-TABLE
                   THRU 15130-LOAD-PTCA-DAY-TABLE-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A COMPREHENSIVE APC     *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = 'J1' OR
                OPPS-SRVC-IND (LN-SUB) = 'J2'
                MOVE 'Y' TO C-APC-CLAIM-FLAG
             END-IF.


       15125-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE PASS-THROUGH CONTRAST AGENT HCPCS COUNT AND     *
      *  CHARGES FOR EACH DAY WITH A PASS-THROUGH CONTRAST AGENT    *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY LINE ITEM DATE OF SERVICE (LIDOS) - *
      *    EARLIEST TO LATEST DATE                                  *
      *                                                             *
      *  EACH PT CONTRAST AGENT HCPCS LINE'S CHARGES ARE ADDED TO   *
      *  THE TOTAL FOR ITS LIDOS.  THESE CHARGES ARE LATER USED     *
      *  TO DETERMINE THE PROPORTION OF THE DAY'S TOTAL CONTRAST    *
      *  PROCEDURE OFFSET THAT SHOULD BE SUBTRACTED FROM A GIVEN PT *
      *  CONTRAST AGENT HCPCS'S LINE PAYMENT.                       *
      *                                                             *
      *  11/16/2009 - LOGIC ADDED FOR CY 2010                       *
      *                                                             *
      ***************************************************************
       15130-LOAD-PTCA-DAY-TABLE.

      *-------------------------------------------------------------*
      * GET THE LINE'S SERVICE DATE & CHARGES FOR TABLE SEARCH      *
      *-------------------------------------------------------------*
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-PTCA-LIDOS.
             MOVE OPPS-SUB-CHRG (LN-SUB)  TO H-SUB-CHRG.

      *-------------------------------------------------------------*
      * ADD OR UPDATE CONTRAST AGENT DAY ENTRY FOR THE LIDOS        *
      *-------------------------------------------------------------*
                PERFORM 15130-SEARCH-PTCA-LIDOS
                   THRU 15130-SEARCH-PTCA-LIDOS-EXIT.

       15130-LOAD-PTCA-DAY-TABLE-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW PT CONTRAST AGENT DAY TABLE RECORD  *
      * SHOULD BE ADDED OR IF AN EXISITING RECORD MUST BE UPDATED   *
      *                                                             *
      ***************************************************************
       15130-SEARCH-PTCA-LIDOS.

      *-------------------------------------------------------------*
      * SEARCH PT CONTRAST AGENT DAY TABLE STARTING AT ENTRY #1     *
      *-------------------------------------------------------------*
             SET W-PTCA-DAY-INDX TO 1.
             SEARCH W-PTCA-DAY-ENTRY VARYING W-PTCA-DAY-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S LIDOS IS NOT ALREADY IN THE TABLE,    *
      * ADD IT                                                      *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 15130-ADD-ENTRY
                      THRU 15130-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S LIDOS IS ALREADY IN THE TABLE,        *
      * UPDATE THE ENTRY                                            *
      *-------------------------------------------------------------*
                WHEN W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX) = H-PTCA-LIDOS
                   PERFORM 15130-UPDATE-ENTRY
                      THRU 15130-UPDATE-ENTRY-EXIT.

       15130-SEARCH-PTCA-LIDOS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW PT CONTRAST AGENT DAY RECORD IN THE CORRECT  *
      * POSITION (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE *
      *                                                             *
      ***************************************************************
       15130-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTCA-DAY-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-PTCA-DAY-INDX TO W-PTCA-DAY-MAX.
             INITIALIZE W-PTCA-DAY-ENTRY (W-PTCA-DAY-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW PT CONTRAST AGENT DAY ENTRY FOR THE *
      * CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE TABLE       *
      * ACCORDING TO ITS LIDOS - EARLIEST TO LATEST LIDOS           *
      *-------------------------------------------------------------*
             PERFORM 15130-STAGE-PTCA-DAY-ENTRY
                THRU 15130-STAGE-PTCA-DAY-ENTRY-EXT
                  UNTIL W-PTCA-DAY-INDX = 1 OR
                     H-PTCA-LIDOS NOT <
                       W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-PTCA-LIDOS TO W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX).
             MOVE 1 TO W-PTCA-DAY-HCPCS-CNT (W-PTCA-DAY-INDX).
             MOVE H-SUB-CHRG TO W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX).

       15130-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING PT CONTRAST AGENT DAY RECORD WITH THE   *
      * SAME LIDOS AS THE CURRENT SERVICE LINE                      *
      *                                                             *
      ***************************************************************
       15130-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE LIDOS'S TOTAL SUBMITTED CHARGES & HCPCS COUNT*
      *-------------------------------------------------------------*
             ADD 1 TO W-PTCA-DAY-HCPCS-CNT (W-PTCA-DAY-INDX).
             ADD H-SUB-CHRG TO W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX).

       15130-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING PT CONTRAST AGENT DAY RECORD WITH A LATER *
      * LIDOS DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR *
      * THE NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.   *
      *                                                             *
      ***************************************************************
       15130-STAGE-PTCA-DAY-ENTRY.

             MOVE W-PTCA-DAY-ENTRY (W-PTCA-DAY-INDX - 1) TO
                  W-PTCA-DAY-ENTRY (W-PTCA-DAY-INDX).
             SET W-PTCA-DAY-INDX DOWN BY 1.

       15130-STAGE-PTCA-DAY-ENTRY-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES, *
      *  AND CALCULATE TOTAL PACKAGED MENTAL HEALTH CHARGES.        *
      *  CREATE PASS-THROUGH CONTRAST AGENT PROC TABLE (NEW CY2010) *
      *  CREATE PASS-THROUGH DEVICE PROC TABLE (NEW OCT 2010)       *
      *                                                             *
      *  ** UPDATE PARTIAL HOSPITALIZATION (PHP) & MENTAL HEALTH    *
      *     (MH) TABLE REFERENCES EVERY JANUARY                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (NOT A PARTIAL HOSPITALIZATION OR       *
      *                      MENTAL HEALTH HCPCS))                  *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (PARTIAL HOSP. APC IS NOT ON THE CLAIM   *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  PARTIAL HOSPITALIZATION HCPCS)      *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       15150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).

      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 15250-CALC-DISCOUNT
                THRU 15250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 15150-INIT-EXIT.

      ***************************************************************
      *  CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH         *
      *  RADIOPHARM OFFSET WHEN PASS-THROUGH RADIOPHARM(S) ON CLAIM *
      *  EFFECTIVE APRIL 2009                                       *
      ***************************************************************
             IF PTRADIO-CLAIM-FLAG = 'Y'
                PERFORM 15165-PROCESS-NUCLEAR-MED
                   THRU 15165-PROCESS-NUCLEAR-MED-EXIT.


      ***************************************************************
      *  CREATE CONTRAST AGENT PROCEDURE TABLE FOR PASS-THROUGH     *
      *  CONTRAST AGENT OFFSET WHEN PT CONTRAST AGENT(S) ON CLAIM   *
      *  EFFECTIVE JANUARY 2010                                     *
      ***************************************************************
             IF PTCA-CLAIM-FLAG = 'Y'
                PERFORM 15168-PROCESS-PTCA-PROC
                   THRU 15168-PROCESS-PTCA-PROC-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      *-------------------------------------------------------------*
             MOVE 'N' TO PHP-HCPCS-FLAG  MH-HCPCS-FLAG
                         PKG-BLD-DED-LINE-FLAG.


      ***************************************************************
      *  SEARCH PARTIAL HOSPITALIZATION (PHP) TABLE FOR LINE HCPCS  *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      *  11/17/2015 - FOR CY 2016, USE CY 2014 TABLE                *
      ***************************************************************
             SEARCH ALL PHP-ENTRY14
                AT END
                   MOVE 'N' TO PHP-HCPCS-FLAG
                WHEN PHP-HCPCS14 (PHP-INDX14) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO PHP-HCPCS-FLAG.


      ***************************************************************
      *  SEARCH MENTAL HEALTH (MH) TABLE FOR LINE HCPCS             *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      *  11/17/2015 - FOR CY 2016, USE CY 2014 TABLE                *
      ***************************************************************
             SEARCH ALL MH-ENTRY14
                AT END
                   MOVE 'N' TO MH-HCPCS-FLAG
                WHEN MH-HCPCS14 (MH-INDX14) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO MH-HCPCS-FLAG.


      ***************************************************************
      *   IDENTIFY LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE ON       *
      *   A CLAIM WITH A COMPREHENSIVE APC; TREAT AS PACKAGED LINE  *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      ***************************************************************
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             END-IF.


      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR ' L' OR
                ' N' OR ' P' OR ' R' OR ' S' OR ' T' OR ' U' OR
                ' V' OR ' X' OR ' W' OR ' Y' OR ' Z' OR ' M' OR
                'J1' OR 'J2')
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 15150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 15150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF ( OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR

      *--------------------------------------------------------*
      *   LINE IS DENIED OR REJECTED AND HAS A PHP OR MH HCPCS *
      *--------------------------------------------------------*
                        OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND

                            ( PHP-HCPCS-FLAG = 'Y' OR
                              MH-HCPCS-FLAG  = 'Y' ) ) OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                      ( OPPS-LITEM-ACT-FLAG (LN-SUB) = '1' )



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      * 11/03/2008 - REMOVED PAFS 91 - 99 FOR COMPOSITES FOR CY 2009*
      * 04/11/2011 - ADDED ' 9' & '10' AS VALID PAFS FOR CY 2011    *
      * 12/18/2014 - ADDED '11' FOR CY 2015                         *
      * 11/10/2015 - ADDED '12' - '14' FOR CY 2016                  *
      * 02/05/2016 - ADDED '16' - '20' FOR CY 2016                  *
      *              (PAF '15' RESERVED FOR FUTURE USE)             *
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8' OR ' 9' OR '10' OR '11'
                             OR '12' OR '13' OR '14'         OR '16'
                             OR '17' OR '18' OR '19' OR '20'


      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *                                                             *
      *   ** SITE OF SERVICE FLAG = PAYMENT METHOD FLAG IN OCE **   *
      *                                                             *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', PHP APC IS ON THE CURRENT LINE       *
      *-------------------------------------------------------------*
      * 11/06/2007 - CHANGED PHP HEALTH CODES LISTED FROM           *
      *              APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008   *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION APC FROM       *
      *              0033 TO 0172 & 0173 FOR CY 2009, FLAG CHANGED  *
      *              FROM APC33-FLAG TO PHP-APC-FLAG                *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID & PHP APC ON CLAIM - CHECK FURTHER  *
      *-------------------------------------------------------------*
                            ( (PHP-APC-FLAG = 'Y') AND

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, PHP APC ON CLAIM, & LINE APC IS PHP*
      *-------------------------------------------------------------*
                                ( (OPPS-SRVC-IND (LN-SUB) = ' P') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, PHP APC ON CLAIM, & LINE PHP HCPCS *
      *-------------------------------------------------------------*
                                  (PHP-HCPCS-FLAG = 'Y') ) )



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE ALL PACKAGED COMPOSITE LINES                      *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *   11/12/2008 - CHANGED LOGIC THAT EXCLUDES ALL COMPOSITE    *
      *                LINES & MENTAL HEALTH PKG LINES TO USE THE   *
      *                COMPOSITE ADJUSTMENT FLAG INSTEAD OF PAYMENT *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *   05/09/2016 - ADDED LOGIC TO ENSURE BLOOD DEDUCTIBLE LINES *
      *                ON CLAIMS WITH A COMPREHENSIVE APC ARE       *
      *                INCLUDED                                     *
      *-------------------------------------------------------------*
                IF ( (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                     (OPPS-COMP-ADJ-FLAG (LN-SUB) = '00') ) OR
                     PKG-BLD-DED-LINE
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED REVENUE CODE 39X BLOOD LINE CHARGES   *
      *   (BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC)      *
      *   WHEN BILLED ON CLAIM WITH A COMPREHENSIVE APC TO          *
      *   DETERMINE THE PORTION OF THE BLOOD APC PAYMENT TO BE      *
      *   DISTRIBUTED TO THE BLOOD PRODUCT (PAF = 5) LINE FOR THE   *
      *   BLOOD DEDUCTIBLE CALCULATION                              *
      *-------------------------------------------------------------*
      *   05/16/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' N' AND
               (OPPS-LITEM-RVCD (LN-SUB) = '0390' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0392' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0399')
                  COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB) +
                                          H-TOT-38X-39X
             END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME (PACKAGED) COMPOSITE APC CHARGES     *
      *   FOR EACH COMPOSITE APC BY THE COMPOSITE ADJUSTMENT FLAG   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2007 - LOGIC REVISED FOR CY 2009 TO IDENTIFY ALL    *
      *                COMPOSITE LINES USING THE COMPOSITE          *
      *                ADJUSTMENT FLAG INSTEAD OF PAYMENT           *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *                (INCLUDES PROCESSING FOR MENTAL HEALTH       *
      *                 COMPOSITES)                                 *
      *-------------------------------------------------------------*
                IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "00" AND
                   OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "  " AND
                   OPPS-SRVC-IND (LN-SUB) = ' N'
                      PERFORM 15170-COMPOSITES
                         THRU 15170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   SET RETURN CODE & EXIT WHEN PACKAGED LINE/LINE APC = 0000 *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 15150-INIT-EXIT
                END-IF


      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 15150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 15175-APC-LOOKUP

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '14' (CT SCAN) *
      *   11/10/2015 - NEW FOR CY 2016; 5% REDUCTION                *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '14'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * CT-REDUCT-2016
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT BY REDUCED UPDATE RATIO WHEN APPROPRIATE   *
      *   11/13/2009 - NEW FOR CY 2009 (QUALITY)                    *
      *-------------------------------------------------------------*
                      PERFORM 15180-REDUCE-APC-PYMT
                         THRU 15180-REDUCE-APC-PYMT-EXIT



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 15150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 15150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 15150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 15150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 15150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 15150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF LINES ELIGIBLE FOR DEVICE CREDIT *
      * WHEN THE CLAIM'S TOTAL DEVICE CREDIT IS > $0 AND THE LINE   *
      * HAS PAYMENT ADJUSTMENT FLAG '17'                            *
      * - REVISED DEVICE CREDIT LOGIC FOR APRIL 2016                *
      ***************************************************************
             IF H-CLAIM-DEVCR-AMT > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17'
                COMPUTE H-TOT-DEVCR-PYMTS =
                        H-TOT-DEVCR-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF TERMINATED PROCEDURE LINES       *
      * ELIGIBLE FOR DEVICE OFFSET WHEN PAYER ONLY VALUE CODE QQ    *
      * IS > $0 AND THE LINE HAS PAYMENT ADJUSTMENT FLAG '16'       *
      * (LINE MODIFIER IS 73)                                       *
      * - IMPLEMENTED IN APRIL 2016                                 *
      ***************************************************************
             IF L-PAYER-ONLY-VC-QQ > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16'
                COMPUTE H-TOT-TPDO-PYMTS =
                        H-TOT-TPDO-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE LINE CHARGES OF PASS-THROUGH DEVICE LINES        *
      * ASSOCIATED WITH PAYER ONLY VALUE CODES QN AND QO            *
      * - LINES WITH PAF '12' RECEIVE OFFSET IN VALUE CODE QN       *
      * - LINES WITH PAF '13' RECEIVE OFFSET IN VALUE CODE QO       *
      * - LINES WITH PAF '15' RECEIVE OFFSET IN VALUE CODE QP       *
      * NEW FOR CY2016 - 11/13/2015                                 *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
                COMPUTE H-QN-TOT-PTD-CHARGES =
                        H-QN-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
                COMPUTE H-QO-TOT-PTD-CHARGES =
                        H-QO-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *         COMPUTE H-QP-TOT-PTD-CHARGES =
      *                 H-QP-TOT-PTD-CHARGES +
      *                 OPPS-SUB-CHRG (LN-SUB)
      *      END-IF.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                PERFORM 15300-COIN-DEDUCT
                   THRU 15300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2009.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                SET W16BD-INDX TO 1
                SEARCH W16BD-ENTRY VARYING W16BD-INDX
                   AT END
                      GO TO 15150-INIT-EXIT
                   WHEN W-2016-BLOOD-HCPCS (W16BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-2016-BLOOD-RANK (W16BD-INDX) TO H-BLOOD-RANK
                     MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                     PERFORM 15375-BLOOD-DEDUCT
                        THRU 15375-BLOOD-DEDUCT-EXIT
                    END-IF.

       15150-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     PROCESS LINES WITH A NUCLEAR MEDICINE APC FOR THE       *
      *              PASS-THROUGH RADIOPHARM OFFSET                 *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE PTROFFST FOR LINE APC & LINE YEAR       *
      *      - IF FOUND, ADD A RECORD TO TABLE W-NUCMED-APC-TBL     *
      *        FOR EVERY UNIT.                                      *
      *                                                             *
      *  02/10/2009 - LOGIC ADDED EFFECTIVE STARTING APRIL 2009     *
      *                                                             *
      ***************************************************************
       15165-PROCESS-NUCLEAR-MED.

      *-------------------------------------------------------------*
      * HOLD THE LINE'S APC, UNITS, & SERVICE FROM DATE             *
      *-------------------------------------------------------------*
             MOVE OPPS-GRP (LN-SUB)        TO W-NUCMED-LINE-APC.
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO W-NUCMED-UNIT-CNT.
             MOVE OPPS-LITEM-DOS (LN-SUB)  TO W-LINE-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT RADIOPHARM OFFSET TABLE FOR THE APC & YEAR        *
      *-------------------------------------------------------------*
             SET PTRO-INDX TO 1.
             SEARCH PTRO-ENTRY
              AT END
                 GO TO 15165-PROCESS-NUCLEAR-MED-EXIT

      *-------------------------------------------------------------*
      * WHEN APC & YEAR FOUND, WAGE ADJUST OFFSET & ADD NEW RECORD  *
      * TO NUCLEAR MEDICINE TABLE FOR EVERY UNIT                    *
      *-------------------------------------------------------------*
              WHEN PTRO-NUCMED-APC (PTRO-INDX) = W-NUCMED-LINE-APC AND
                   PTRO-EFF-YEAR (PTRO-INDX) = W-LINE-SRVC-YEAR
                     MOVE PTRO-OFFSET-AMT (PTRO-INDX) TO W-NUCMED-OFFSET
                     COMPUTE W-NUCMED-WA-OFFSET ROUNDED =
                             W-NUCMED-OFFSET * (.6 * A-WINX + .4)
                     PERFORM 15166-LOAD-NUCMED-TABLE
                        THRU 15166-LOAD-NUCMED-TABLE-EXIT
                        VARYING W-NUCMED-SUB FROM 1 BY 1
                        UNTIL W-NUCMED-SUB > W-NUCMED-UNIT-CNT.

       15165-PROCESS-NUCLEAR-MED-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * LOAD A NUCLEAR MEDICINE APC TABLE RECORD FOR EVERY UNIT OF  *
      * THE NUCLEAR MEDICINE LINE AND WAGE ADJUST 60% OF THE OFFSET *
      * (INSERT THE NEW RECORD IN THE CORRECT TABLE POSITION -      *
      *  HIGHEST TO LOWEST OFFSET)                                  *
      *                                                             *
      ***************************************************************
       15166-LOAD-NUCMED-TABLE.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-NUCMED-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW (LAST) ENTRY POSITION (EMPTY RECORD)        *
      *-------------------------------------------------------------*
             SET W-NUCMED-INDX TO W-NUCMED-MAX.
             INITIALIZE W-NUCMED-APC-ENTRY (W-NUCMED-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW NUCMED APC ENTRY FOR THE CURRENT    *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS OFFSET VALUE - HIGHEST TO LOWEST OFFSET                 *
      *-------------------------------------------------------------*
             PERFORM 15167-STAGE-NUCMED-ENTRY
                THRU 15167-STAGE-NUCMED-ENTRY-EXIT
                  UNTIL W-NUCMED-INDX = 1 OR
                     W-NUCMED-WA-OFFSET NOT >
                        W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE W-NUCMED-LINE-APC TO W-NUCMED-APC (W-NUCMED-INDX).
             MOVE W-NUCMED-WA-OFFSET TO
                  W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX).

       15166-LOAD-NUCMED-TABLE-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING NUCMED APC RECORD WITH A HIGHER OFFSET    *
      * DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE   *
      * NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.       *
      *                                                             *
      ***************************************************************
       15167-STAGE-NUCMED-ENTRY.

             MOVE W-NUCMED-APC-ENTRY (W-NUCMED-INDX - 1) TO
                  W-NUCMED-APC-ENTRY (W-NUCMED-INDX).
             SET W-NUCMED-INDX DOWN BY 1.

       15167-STAGE-NUCMED-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  PROCESS LINES WITH A PASS-THROUGH CONTRAST AGENT PROCEDURE *
      *        APC FOR THE PASS-THROUGH CONTRAST AGENT OFFSET       *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE PTCOFFST FOR LINE APC & LINE YEAR       *
      *      - IF FOUND, ADD A RECORD TO TABLE W-CAPROC-APC-TBL     *
      *        FOR EVERY UNIT.                                      *
      *                                                             *
      *  11/16/2009 - LOGIC ADDED EFFECTIVE STARTING JANUARY 2010   *
      *                                                             *
      ***************************************************************
       15168-PROCESS-PTCA-PROC.

      *-------------------------------------------------------------*
      * HOLD THE LINE'S APC, UNITS, & LINE ITEM DATE OF SERVICE     *
      *-------------------------------------------------------------*
             MOVE OPPS-GRP (LN-SUB)        TO W-CAPROC-LINE-APC.
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO W-CAPROC-UNIT-CNT.
             MOVE OPPS-LITEM-DOS (LN-SUB)  TO W-CAPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT CONTRAST AGENT OFFSET TABLE FOR THE APC & YEAR    *
      *-------------------------------------------------------------*
             SET PTCO-INDX TO 1.
             SEARCH PTCO-ENTRY
              AT END
                 GO TO 15168-PROCESS-PTCA-PROC-EXIT

      *-------------------------------------------------------------*
      * WHEN APC & YEAR FOUND, WAGE ADJUST OFFSET & ADD NEW RECORD  *
      * TO PT CONTRAST PROCEDURE APC TABLE FOR EVERY UNIT           *
      *-------------------------------------------------------------*
              WHEN PTCO-CONTR-APC (PTCO-INDX) = W-CAPROC-LINE-APC AND
                   PTCO-EFF-YEAR (PTCO-INDX) = W-CAPROC-SRVC-YEAR
                     MOVE PTCO-OFFSET-AMT (PTCO-INDX) TO W-CAPROC-OFFSET
                     COMPUTE W-CAPROC-WA-OFFSET ROUNDED =
                             W-CAPROC-OFFSET * (.6 * H-WINX + .4)
                     PERFORM 15168-LOAD-PTCA-PROC-TABLE
                        THRU 15168-LOAD-PTCA-PROC-TABLE-EXT
                        VARYING W-CAPROC-SUB FROM 1 BY 1
                        UNTIL W-CAPROC-SUB > W-CAPROC-UNIT-CNT.

       15168-PROCESS-PTCA-PROC-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * LOAD A PT CONTRAST AGENT PROCEDURE APC TABLE RECORD FOR     *
      * EVERY UNIT OF THE PT CONTRAST AGENT PROCEDURE LINE          *
      * (INSERT THE NEW RECORD IN THE CORRECT TABLE POSITION -      *
      *  EARLIEST TO LATEST LIDOS, THEN HIGHEST TO LOWEST OFFSET)   *
      *                                                             *
      ***************************************************************
       15168-LOAD-PTCA-PROC-TABLE.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CAPROC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW (LAST) ENTRY POSITION (EMPTY RECORD)        *
      *-------------------------------------------------------------*
             SET W-CAPROC-INDX TO W-CAPROC-MAX.
             INITIALIZE W-CAPROC-APC-ENTRY (W-CAPROC-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW CAPROC APC ENTRY FOR THE CURRENT    *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS LIDOS & OFFSET VALUE (EARLIEST TO LATEST, HIGHEST TO    *
      * LOWEST)                                                     *
      *-------------------------------------------------------------*
             PERFORM 15168-STAGE-PTCA-PROC-ENTRY
                THRU 15168-STAGE-PTCA-PROC-ENTRY-EX
                  UNTIL W-CAPROC-INDX = 1 OR
                     W-CAPROC-KEY NOT >
                        W-CAPROC-TBL-KEY (W-CAPROC-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE W-CAPROC-LINE-APC TO W-CAPROC-APC (W-CAPROC-INDX).
             MOVE W-CAPROC-KEY TO W-CAPROC-TBL-KEY (W-CAPROC-INDX).

       15168-LOAD-PTCA-PROC-TABLE-EXT.
             EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING NUCMED APC RECORD WITH A HIGHER OFFSET    *
      * DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE   *
      * NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.       *
      *                                                             *
      ***************************************************************
       15168-STAGE-PTCA-PROC-ENTRY.

             MOVE W-CAPROC-APC-ENTRY (W-CAPROC-INDX - 1) TO
                  W-CAPROC-APC-ENTRY (W-CAPROC-INDX).
             SET W-CAPROC-INDX DOWN BY 1.

       15168-STAGE-PTCA-PROC-ENTRY-EX.
             EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH COMPOSITE          *
      *  ADJUSTMENT FLAG NOT = '00' & POPULATE COMPOSITE APC TABLE  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY COMPOSITE ADJUSTMENT FLAG (CAF) -   *
      *    LOWEST TO HIGHEST FLAG VALUE (01 - NN)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH CAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *  11/12/2008 - LOGIC REVISED FOR CY 2009 TO USE THE          *
      *               COMPOSITE ADJUSTMENT FLAG INSTEAD OF THE      *
      *               PAYMENT ADJUSTMENT FLAG, VARIABLE H-CMP-CAF   *
      *               HOLDS COMPOSITE ADJUSTMENT FLAG, VARIABLE     *
      *               W-CMP-PAF RETAINED AND NOW HOLDS THE CAF      *
      *               (RETAINED TO CONTINUE USE OF EXISTING TABLE)  *
      *                                                             *
      ***************************************************************
       15170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S COMPOSITE ADJUSTMENT FLAG FOR TABLE SEARCH   *
      *-------------------------------------------------------------*
             MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE CAF         *
      *-------------------------------------------------------------*
                PERFORM 15171-SEARCH-CAF
                   THRU 15171-SEARCH-CAF-EXIT.

       15170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       15171-SEARCH-CAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS NOT      *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 15172-ADD-ENTRY
                      THRU 15172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS ALREADY  *
      * IN THE TABLE, UPDATE THE ENTRY                              *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                   PERFORM 15173-UPDATE-ENTRY
                      THRU 15173-UPDATE-ENTRY-EXIT.

       15171-SEARCH-CAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       15172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS COMPOSITE ADJUSTMENT FLAG (CAF) - LOWEST TO HIGHEST CAF *
      *-------------------------------------------------------------*
             PERFORM 15174-STAGE-CMP-ENTRY
                THRU 15174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-CAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-CAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       15172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * COMPOSITE ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE       *
      *                                                             *
      ***************************************************************
       15173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE CAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       15173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER CAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       15174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       15174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       15175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 15175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       15175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      REDUCE APC PAYMENT OF LINES FROM PROVIDERS WITH A      *
      *      SPACE IN THE QUALITY INDICATOR FIELD OF THE OPSF       *
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      *  11/16/2010 - ADDED SI = U (BRACHY) TO LOGIC                *
      *                                                             *
      ***************************************************************
       15180-REDUCE-APC-PYMT.

      *-------------------------------------------------------------*
      *  SPECIFY LINES ELIGIBLE FOR REDUCTION                       *
      *  11/13/2019- QUALITY ADJUSTMENT EXCLUSION FOR NEW TECHNOLOGY*
      *  CATEGORY APC RANGES:                                       *
      *             - 1575-1599 (EFF. 1/1/2016)                     *
      *-------------------------------------------------------------*
             IF ( L-PSF-HOSP-QUAL-IND = ' ' )  AND

                (  (OPPS-SRVC-IND (LN-SUB) = ' P')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' R')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' S' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01491' AND
                           OPPS-GRP (LN-SUB) <= '01537') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01575' AND
                           OPPS-GRP (LN-SUB) <= '01585'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' T' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01539' AND
                           OPPS-GRP (LN-SUB) <= '01574') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01589' AND
                           OPPS-GRP (LN-SUB) <= '01599'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' U')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' V')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' X')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J1')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J2')  ) THEN

                COMPUTE H-APC-PYMT ROUNDED = H-APC-PYMT * 0.980
                MOVE 11 TO A-RETURN-CODE (LN-SUB)

             END-IF.


       15180-REDUCE-APC-PYMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       15200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   IF W-WINX-LOOKUP
                      MOVE  50  TO A-CLM-RTN-CODE
                   END-IF
                   GO TO 15200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA

      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 15210-WAGE-LOOKUP.

      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0 OR NOT NUMERIC             *
      *   *AND* NOT ON RURAL FLOOR LOOKUP                           *
      ***************************************************************

             IF (H-WINX = 0 OR H-WINX NOT NUMERIC) AND
                 W-WINX-LOOKUP THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       15200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       15210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE MEETS THE CRITERIA:       *
      *  - MUST NOT BE AFTER THE LATEST WAGE INDEX EFFECTIVE DATE   *
      *    THAT CAN BE USED BY THE CLAIM                            *
      *  - EXCEPT FOR INDIAN HEALTH PROVIDERS (CBSAS 98 AND 99),    *
      *    MUST BE WITHIN THE CLAIM'S CALENDAR YEAR                 *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD / LATEST         *
      *   EFFECTIVE DATE FOR THE CBSA)                              *
      ***************************************************************
             MOVE WCW-DTCD (W-SUB3) TO W-WCW-DTCD.

             IF W-WCW-DTCD NOT > WCD-DTCD (WCD-SUB) AND

                ( (WCD-DATE (W-WCW-DTCD) >= W-CY-BEGIN-DATE AND
                   WCD-DATE (W-WCW-DTCD) <= W-CY-END-DATE AND
                   H-PSF-CBSA NOT = '   98' AND
                   H-PSF-CBSA NOT = '   99') OR

                  (H-PSF-CBSA = '   98' OR
                   H-PSF-CBSA = '   99') )

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *   *ONLY VALID FOR WAGE INDEX LOOKUP, NOT RURAL FLOOR*       *
      *   IF WAGE INDEX > FLOOR, OVERWRITE H-WINX                   *
      *-------------------------------------------------------------*
                IF L-PSF-SPEC-PYMT-IND = 'Y' AND W-WINX-LOOKUP THEN
                   IF WCW-WINX2 (W-SUB3) > H-WINX THEN
                      MOVE WCW-WINX2 (W-SUB3) TO H-WINX
                   END-IF
      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *   IF WAGE INDEX > FLOOR OR LOOKING UP RURAL FLOOR, STORE    *
      *   RESULT IN H-WINX.                                         *
      *-------------------------------------------------------------*
                ELSE
                   IF (WCW-WINX1 (W-SUB3) > H-WINX OR W-FLOOR-LOOKUP)
                      MOVE WCW-WINX1 (W-SUB3) TO H-WINX
                   END-IF
                END-IF


      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE DID NOT MEET THE CRITERIA *
      *  - AFTER THE LATEST EFFECTIVE DATE THE CLAIM CAN USE -OR-   *
      *  - NOT WITHIN THE CLAIM'S CALENDAR YEAR AND NOT IN CBSA     *
      *    98 OR 99                                                 *
      *  GO TO THE PRIOR RECORD FOR THIS CBSA WITH AN EARLIER DATE  *
      *  IN THE CBSA WAGE INDEX TABLE.                              *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *  AGAIN AND REPEAT THE PROCESS
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 15210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      * >10-28-2014 ONLY VALID FOR WAGE INDEX PASS, NOT RURAL FLOOR *
      *-------------------------------------------------------------*
                ELSE

                   IF W-WINX-LOOKUP
                      MOVE 0 TO H-WINX
                END-IF
             END-IF.

       15210-WAGE-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       15250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 15250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       15250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       15300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 15350-STAGE-ENTRY
                THRU 15350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX      TO W-WINX (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       15300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       15350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       15350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       15375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 15385-STAGE-ENTRY
                THRU 15385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX     TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       15375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       15385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       15385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SUM PASS-THROUGH CONTRAST AGENT OFFSET AMOUNT(S) FOR EACH   *
      * DAY ON WHICH A PASS-THROUGH CONTRAST AGENT APPEARS          *
      *                                                             *
      ***************************************************************
       15396-TOTAL-DAY-PTCA-OFFS.

      *-------------------------------------------------------------*
      * CAPTURE DATE OF SERVICE FROM PT CONTRAST AGENT DAY TABLE    *
      *-------------------------------------------------------------*
             MOVE W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX)
               TO W-CAPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * MOVE TO FIRST RECORD IN PT CONTRAST AGENT PROCEDURE APC TBL *
      *-------------------------------------------------------------*
             SET W-CAPROC-INDX TO 1.

      *-------------------------------------------------------------*
      * START COUNTER THAT MONITORS THE # OF OFFSETS ADDED          *
      *-------------------------------------------------------------*
             MOVE 1 TO W-CAPROC-UNIT-CNT.

             SEARCH W-CAPROC-APC-ENTRY

      *-------------------------------------------------------------*
      * DATE OF SERVICE NOT FOUND IN TABLE, STOP PROCESS            *
      *-------------------------------------------------------------*
                AT END
                   GO TO 15396-TOTAL-DAY-PTCA-OFFS-EXIT

      *-------------------------------------------------------------*
      * DATE OF SERVICE FOUND IN TABLE, ACCUMULATE OFFSETS          *
      *-------------------------------------------------------------*
                WHEN W-CAPROC-LIDOS (W-CAPROC-INDX) = W-CAPROC-SRVC-DATE
                     PERFORM UNTIL
      *     *-------------------------------------------------------*
      *     * STOP SEARCH WHEN END OF TABLE REACHED                 *
      *     *-------------------------------------------------------*
                        (W-CAPROC-INDX > W-CAPROC-MAX) OR
      *     *-------------------------------------------------------*
      *     * STOP SEARCH WHEN NUMBER OF DAY'S HCPCS LINES EXCEEDED *
      *     *-------------------------------------------------------*
                        (W-CAPROC-UNIT-CNT >
                           W-PTCA-DAY-HCPCS-CNT (W-PTCA-DAY-INDX)) OR
      *     *-------------------------------------------------------*
      *     * STOP SEARCH WHEN DATE OF SERVICE CHANGES              *
      *     *-------------------------------------------------------*
                        (W-CAPROC-LIDOS (W-CAPROC-INDX) NOT =
                           W-CAPROC-SRVC-DATE)

      *     *-------------------------------------------------------*
      *     * ADD PT CONTRAST AGENT PROCEDURE OFFSET TO DAY TOTAL   *
      *     *-------------------------------------------------------*
                        COMPUTE W-PTCA-DAY-TOT-OFFSET (W-PTCA-DAY-INDX)
                          ROUNDED =
                             W-PTCA-DAY-TOT-OFFSET (W-PTCA-DAY-INDX) +
                             W-CAPROC-WAGE-ADJ-OFFSET (W-CAPROC-INDX)

      *     *-------------------------------------------------------*
      *     * SET POINTER TO NEXT PROCEDURE RECORD                  *
      *     *-------------------------------------------------------*
                        SET W-CAPROC-INDX UP BY 1
                        ADD 1 TO W-CAPROC-UNIT-CNT
                     END-PERFORM
             END-SEARCH.

       15396-TOTAL-DAY-PTCA-OFFS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PAYMENTS, DEDUCTIBLES, REIM., & COINSURANCE,*
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       15400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 15400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 15550-CALC-STANDARD
                   THRU 15550-CALC-STANDARD-EXIT
             ELSE
                GO TO 15400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRUG COINSURANCE TABLE FOR LATER PROCESSING        *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET GJK-FLAG WHEN SERVICE = G OR K                       *
      *-------------------------------------------------------------*
             IF (A-RETURN-CODE (LN-SUB) <  30) AND
                NOT PKG-BLD-DED-LINE
                PERFORM 15450-ADJ-PROC-COIN
                   THRU 15450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 15500-ADJ-CHRGS
                THRU 15500-ADJ-CHRGS-EXIT.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

                COMPUTE A-DEVICE-CREDIT-QD =
                        A-DEVICE-CREDIT-QD + H-LINE-DEVCR-AMT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 15840-PROCESS-TYPE2     *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)

               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       15400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE DRUG COINSURANCE ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: DRUG / BLOOD LINE                       *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY DRUG LINE          *
      *   ("DRUG" REFERS TO ANY SI = G OR K LINE FOR SIMPLICITY)    *
      *                                                             *
      * DRUG COINSURANCE RECORD COMBINATIONS:                       *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       DRUG(S) ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO DRUG(S) ADMINISTERED ON THE *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH DRUG(S) ADMINISTERED ON THE    *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = G OR K =>          *
      *       DRUG ADMINSTERED ON THE DATE OF SERVICE               *
      *                                                             *
      ***************************************************************
       15450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                PERFORM 15455-SEARCH-KEY
                   THRU 15455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = G, K, & R LINES ("DRUG" & BLOOD)               *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET GJK-FLAG TO INDICATE "DRUG" LINE                        *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO GJK-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                   PERFORM 15455-SEARCH-KEY
                      THRU 15455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY DRUG LINE) *
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = G OR K  *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 15475-STAGE-DCP-ENTRY
                      THRU 15475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, "DRUG"                                       *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       15450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW DRUG/DEVICE COINSURANCE TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       15455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH DRUG/DEVICE COINSURANCE TABLE STARTING AT ENTRY #1   *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 15460-ADD-ENTRY
                      THRU 15460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 15465-UPDATE-ENTRY
                      THRU 15465-UPDATE-ENTRY-EXIT.

       15455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE DRUG / DEVICE COINSURANCE TABLE                         *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       15460-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 15475-STAGE-DCP-ENTRY
                THRU 15475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, "DRUG"                                       *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       15460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING DRUG COINSURANCE RECORD WITH THE SAME   *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       15465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR "DRUG" LINES - ACCUMULATE DAY'S TOTAL "DRUG" COIN DUE   *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A "DRUG" LINE, UPDATE THE RECORD  *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 15485-REPLACE-TYPE1
                     THRU 15485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 15480-RANK-COIN
                     THRU 15480-RANK-COIN-EXIT.

       15465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING DRUG COINSURANCE RECORD WITH A HIGHER     *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       15475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       15475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST WAGE ADJ.  *
      * NATIONAL COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE  *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       15480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       15480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = G OR K   *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = DRUG / BLOOD LINE NEW COINSURANCE AMOUNT(S)       *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       15485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       15485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 15600-ADJ-CHRG-OUTL.)                     *
      *                                                             *
      ***************************************************************
       15500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
      * 12/18/2009 - ADD SIS R & U, WHICH ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P' OR ' R' OR ' U' OR 'J1' OR 'J2')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                AND NOT PKG-BLD-DED-LINE
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       15500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    AND DRUGS & TAKE PT DEVICE OFFSET WHEN APPLICABLE        *
      * 5. CALCULATE AND APPLY DEVICE CREDIT                        *
      *                                                             *
      ***************************************************************
       15550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 15655-SET-BD-HCPCS-FLAG
                THRU 15655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      *   FLAG LINE IF ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND CLAIM  *
      *   HAS A COMPREHENSIVE APC; TREAT AS PACKAGED LINE           *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             ELSE
                  MOVE 'N' TO PKG-BLD-DED-LINE-FLAG
             END-IF.

      *-------------------------------------------------------------*
      * FLAG LINE IF LINE HCPCS IS A PASS-THROUGH RADIOPHARM HCPCS  *
      * ** QUARTERLY UPDATES TO TABLE **                            *
      *-------------------------------------------------------------*
      * 02/10/2009 - PT RADIOPHARM HCPCS CHECK ADDED                *
      *-------------------------------------------------------------*
             PERFORM 15680-SET-PTRADIO-LINE-FLAG
                THRU 15680-SET-PTRADIO-LINE-FL-EXIT.

      *-------------------------------------------------------------*
      * FLAG LINE IF LINE HCPCS IS A PASS-THROUGH CONTRAST AGENT    *
      * HCPCS ** QUARTERLY UPDATES TO TABLE **                      *
      *-------------------------------------------------------------*
      * 11/16/2009 - PT CONTRAST AGENT HCPCS CHECK ADDED            *
      *-------------------------------------------------------------*
             PERFORM 15681-SET-PTCA-LINE-FLAG
                THRU 15681-SET-PTCA-LINE-FL-EXIT.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).


      ***************************************************************
      * CALCULATE DEVICE CREDIT FOR ELIGIBLE LINE(S)                *
      *-------------------------------------------------------------*
      * 02/09/2016- REVISED LOGIC IMPLEMENTED IN APRIL 2016         *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-CLAIM-DEVCR-AMT > 0 AND
                H-TOT-DEVCR-PYMTS > 0
                PERFORM 15550-DEVICE-CREDIT
                   THRU 15550-DEVICE-CREDIT-EXIT.


      ***************************************************************
      * CALCULATE DEVICE OFFSET FOR ELIGIBLE TERMINATED PROCEDURE   *
      * LINES AND REDUCE THE APC PAYMENT BY THE DEVICE OFFSET AMOUNT*
      *-------------------------------------------------------------*
      * 02/09/2016- NEW LOGIC IMPLEMENTED IN APRIL 2016             *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16' AND
                L-PAYER-ONLY-VC-QQ > 0 AND
                H-TOT-TPDO-PYMTS > 0
                PERFORM 15550-TERM-PROC-DEV-OFF
                   THRU 15550-TERM-PROC-DEV-OFF-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, X, J1, OR J2 LINES   *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X' OR
                 'J1' OR 'J2') THEN
                  PERFORM 15550-SCH-ADJ
                     THRU 15550-SCH-ADJ-EXIT
                  PERFORM 15560-CALC-BENE-DEDUCT
                     THRU 15560-CALC-BENE-DEDUCT-EXIT

                  IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                     PERFORM 15550-PHP-PMT-FOR-OUTL
                        THRU 15550-PHP-PMT-FOR-OUTL-EXIT
                  END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (PT DEVICE) LINES, PAYMENT IND.*
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      *-------------------------------------------------------------*
      * 01/01/2009 - BRACHYTHERAPY SERVICES ADDED FOR CY 2009       *
      * 11/15/2009 - BRACHYTHERAPY SERVICES (SI=U) REMOVED CY 2010  *
      *            - THERAPEUTIC RADIOPHARMS' SI NOT 'H' FOR CY2010 *
      * 08/11/2010 - NEW PASS-THROUGH DEVICE OFFSET LOGIC ADDED IN  *
      *              PARAGRAPH 10555-CALC-H-STANDARD                *
      * 11/16/2015 - REVISED PT-DEVICE LOGIC: 15555-CALC-H-STANDARD *
      ***************************************************************
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' H') THEN
                 IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                       OPPS-PYMT-IND (LN-SUB) = ' 6')
                   PERFORM 15555-CALC-H-STANDARD
                      THRU 15555-CALC-H-STANDARD-EXIT
                   PERFORM 15560-CALC-BENE-DEDUCT
                      THRU 15560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 15550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = G, K, R & U LINES; THE PMT. IND. *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      * 11/15/2009 - ADDED BRACHYTHERAPY SERVICES (SI=U) FOR CY2010 *
      *              THERAPEUTIC RADIOPHARMS' SI=K FOR CY 2010      *
      * 11/16/2009 - ADD LOGIC TO ADJUST PT CONTRAST AGENT HCPCS    *
      *              LINE PAYMENT BY OFFSET                         *
      * 05/10/2016 - CALCULATE BLOOD DEDUCTIBLE & LINE PAYMENT FOR  *
      *              BLOOD DEDUCTIBLE LINES ON COMPREHEMSIVE APC    *
      *              CLAIMS (THESE LINES WERE PREVIOUSLY PACKAGED)  *
      *            - ADD LOGIC TO EXEMPT BLOOD DEDUCTIBLE LINES ON  *
      *              COMPREHENSIVE APC CLAIMS FROM REIM, COIN, &    *
      *              NON-BLOOD DEDUCTIBLE CALCS.                    *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) =
                    ' G' OR ' K' OR ' R' OR ' U' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 15550-CALC-GJK
                         THRU 15550-CALC-GJK-EXIT

                      IF PKG-BLD-DED-LINE
                         NEXT SENTENCE
                      END-IF

                      IF PTRADIO-LINE-FLAG = 'Y' AND
                         H-NUCMED-TOT-OFFSET > 0 THEN
                         PERFORM 15550-PTRADIO-OFFSET
                            THRU 15550-PTRADIO-OFFSET-EXIT
                      END-IF

                      IF PTCA-LINE-FLAG = 'Y' AND
                         W-PTCA-DAY-MAX > 0 AND
                         W-CAPROC-MAX > 0 THEN
                         PERFORM 15550-PTCA-OFFSET
                            THRU 15550-PTCA-OFFSET-EXIT
                      END-IF

                      PERFORM 15560-CALC-BENE-DEDUCT
                         THRU 15560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 15550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      * 11/12/2008 - BRACHYTHERAPY SOURCE'S STATUS INDICATOR = ' U' *
      *              EFFECTIVE 1/1/2009                             *
      *                                                             *
      * 11/16/2009 - REMOVED LOGIC FOR THERAPEUTIC RADIOPHARMS &    *
      *              BRACHYTHERAPY SOURCES B/C THESE ARE NOT PAID   *
      *              AT COST FOR CY 2010                            *
      *                                                             *
      * 04/11/2011 - ADDED LOGIC TO PREVENT LINES WITH PAFS 9 OR 10 *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      * 05/13/2016 - ADDED LOGIC FOR BLOOD DEDUCTIBLE LINES ON A    *
      *              COMPREHENSIVE APC CLAIM (ZERO OUT REIM, COIN,  *
      *              & NON-BLOOD DEDUCTIBLE)                        *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * FOR BLOOD DEDUCTIBLE LINES ON A COMPREHENSIVE APC CLAIM:    *
      * SET REIMBURSEMENT, COINSURANCE, & DEDUCTIBLE AMOUNTS TO $0  *
      *-------------------------------------------------------------*
             IF PKG-BLD-DED-LINE
                MOVE 0 TO H-LITEM-REIM
                          H-TOTAL-LN-DEDUCT
                          H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 15550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE REIMBURSEMENT AND SET COINSURANCE AMOUNTS TO $0   *
      * FOR LINES WITH A PAF= 9 OR 10                               *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 9' OR '10')
                COMPUTE H-LITEM-REIM ROUNDED =
                   H-LITEM-PYMT - H-TOTAL-LN-DEDUCT
                MOVE 0 TO H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 15550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                  H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX).


      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DRUGS, DEVICES, BRACHYTHERAPY, THERAP. RADIO, & BLOOD       *
      * (SI = G AND H LINES HAVE A MIN-COIN = 0, WON'T ENTER LOGIC) *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) =
                  ' G' OR ' H' OR ' K' OR ' R' OR ' U'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       15550-CALC-STANDARD-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE LINE'S DEVICE CREDIT AMOUNT                   *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - REVISED LOGIC IMPLEMENTED APRIL 2016           *
      *                                                             *
      ***************************************************************
       15550-DEVICE-CREDIT.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE CREDIT     *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-DEVCR-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-DEVCR-PYMTS.

           COMPUTE H-LINE-DEVCR-AMT ROUNDED =
                   H-CLAIM-DEVCR-AMT * H-LINE-DEVCR-PYMT-RATE.

       15550-DEVICE-CREDIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE TERMINATED PROCEDURE LINE'S DEVICE OFFSET     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - NEW FOR CY 2016 (APRIL IMPLEMENTATION)         *
      *                                                             *
      ***************************************************************
       15550-TERM-PROC-DEV-OFF.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE OFFSET     *
      * FOR TERMINATED PROCEDURES                                   *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-TPDO-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-TPDO-PYMTS.

           COMPUTE H-LINE-TPDO-AMT ROUNDED =
                   L-PAYER-ONLY-VC-QQ * H-LINE-TPDO-PYMT-RATE.

      *-------------------------------------------------------------*
      * ADJUST THE BASE APC PAYMENT BY THE DEVICE OFFSET            *
      *-------------------------------------------------------------*
           IF W-APC-PYMT (W-LP-INDX) >= H-LINE-TPDO-AMT
              COMPUTE W-APC-PYMT (W-LP-INDX) ROUNDED =
                      W-APC-PYMT (W-LP-INDX) - H-LINE-TPDO-AMT
           ELSE
              MOVE 0 TO W-APC-PYMT (W-LP-INDX)
           END-IF.

       15550-TERM-PROC-DEV-OFF-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *        FOR LINES WITH A SI OF S, V, T, P, X, R, OR U        *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA MUST BE A  *
      *   VALUE OF '   01' THRU '   99' AND THE L-PSF-PROV-TYPE     *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2009: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      * 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES (SI=R)     *
      *              ADDED TO LOGIC.  BRACHY LINES NOT PROCESSED IN *
      *              PARAGRAPH & NOW HAVE A SI = U, SI = K LOGIC    *
      *              REMOVED FROM THIS PARAGRAPH.                   *
      * 05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD    *
      *              DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.     *
      *              FIX EFFECTIVE RETROACTIVE TO 01/01/2009.       *
      * 11/17/2009 - BRACHYTHERAPY LINES NOW PROCESSED IN THIS      *
      *              PARAGRAPH FOR CY 2010 (SI=U), DO NOT RECEIVE   *
      *              WAGE ADJUSTMENT                                *
      * 05/09/2011 - REVISED LOGIC TO EXCLUDE BILL TYPE 14X FROM    *
      *              RECEIVING THE SCH ADD-ON                       *
      * 02/07/2012 - REPLACE BILL14X-FLAG WITH CONDITION NAME       *
      *              BILL-TYPE-14X                                  *
      * 01/27/2014 - WHEN APPLICABLE, SUBTRACT DEVICE CREDIT        *
      *              AMOUNT FROM LINE ITEM PAYMENT                  *
      *                                                             *
      ***************************************************************
       15550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      ***************************************************************

             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22') AND
                 (NOT BILL-TYPE-14X))

      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      ***************************************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = R (BLOOD) OR U (BRACHY) LINES ARE NOT WAGE-ADJUSTED    *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U'
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.

      *-------------------------------------------------------------*
      * REDUCE ADJUSTED APC PAYMENT BY DEVICE CREDIT IF APPLICABLE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-LINE-DEVCR-AMT > 0
                IF H-LITEM-PYMT >= H-LINE-DEVCR-AMT
                   COMPUTE H-LITEM-PYMT ROUNDED =
                           H-LITEM-PYMT - H-LINE-DEVCR-AMT
                ELSE
                   MOVE 0 TO H-LITEM-PYMT
                END-IF
             END-IF.


       15550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *         SET PARTIAL HOSPITALIZATION (PHP) "CAP" APC         *
      *             FOR USE IN THE OUTLIER CALCULATION              *
      *                  (FOR SI = P LINES ONLY)                    *
      *                                                             *
      *       ** ASK POLICY FOR THE PHP "CAP" APC ANUALLY **        *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/13/2008 - THIS PARAGRAPH IS NEW FOR CY 2009,             *
      *              CY 2009 PHP "CAP" APC = 0173                   *
      * 11/15/2010 - MODIFIED LOGIC TO ASSIGN CMHCS APC 00173 &     *
      *              HOSPITALS APC 00176                            *
      * 11/04/2011 - MODIFIED LOGIC TO STOP APPLYING APC 00176      *
      *              CAP TO PHP HOSPITAL LINES                      *
      * 11/17/2015 - UPDATED APC FOR CY 2016                        *
      *                                                             *
      ***************************************************************
       15550-PHP-PMT-FOR-OUTL.

      *-------------------------------------------------------------*
      *  ** FOR CMHC CLAIMS ONLY - USE APC 00173                    *
      *  LOOK-UP PHP "CAP" APC IN THE APC TABLE, STARTING AT        *
      *  THE APC'S MOST CURRENT RECORD - RETRIEVE PAYMENT RATE      *
      *-------------------------------------------------------------*
             IF (L-PSF-PROV-3456 >= '1400' AND
                 L-PSF-PROV-3456 <= '1499') OR
                (L-PSF-PROV-3456 >= '4600' AND
                 L-PSF-PROV-3456 <= '4799') OR
                (L-PSF-PROV-3456 >= '4900' AND
                 L-PSF-PROV-3456 <= '4999')
              SEARCH ALL WAA-ENTRY
                AT END
                   GO TO 15550-PHP-PMT-FOR-OUTL-EXIT

                WHEN WAA-APC (WAA-INDX) = '05852'
                   MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                   PERFORM 15550-PHP-APC-LOOKUP.
      *-------------------------------------------------------------*
      * REDUCE APC PMT RATE BY REDUCED UPDATE RATIO WHEN APPROPRIATE*
      * 11/13/2009 - NEW FOR CY 2009                                *
      *-------------------------------------------------------------*
             PERFORM 15180-REDUCE-APC-PYMT
                THRU 15180-REDUCE-APC-PYMT-EXIT.

      *-------------------------------------------------------------*
      * APPLY THE SCH ADJUSTMENT TO APC RATE WHEN APPLICABLE        *
      * CY 2009 ADJ = 7.1%                                          *
      *-------------------------------------------------------------*
             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))
                     COMPUTE H-APC-PYMT ROUNDED =
                         (H-APC-PYMT * 1.071)
             END-IF.

      *-------------------------------------------------------------*
      *  CALCULATE THE PHP "CAP" APC'S LINE PAYMENT (INCLUDES       *
      *  WAGE ADJUSTMENT AND SCH ADJUSTMENT IF APPLICABLE)          *
      *-------------------------------------------------------------*
             COMPUTE H-PHP-LITEM-PYMT-OUTL ROUNDED =
                       (((H-APC-PYMT * .60) *
                            W-WINX (W-LP-INDX)) +
                         (H-APC-PYMT * .40)) *
                       W-SRVC-UNITS (W-LP-INDX) *
                       W-DISC-RATE (W-LP-INDX).

       15550-PHP-PMT-FOR-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            LOOK-UP PHP "CAP" APC IN THE APC TABLE           *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/13/2008 - THIS PARAGRAPH IS NEW FOR CY 2009              *
      *                                                             *
      ***************************************************************
       15550-PHP-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE ZEROS TO H-APC-PYMT

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 15550-PHP-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT.

       15550-PHP-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = G, K, R, & U LINES:  *
      *   - APC PAYMENT FOR BLOOD LINES (SI = R)                    *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = G, K, OR U LINES (DRUGS,     *
      *     BIOLOGICALS, RADIOPHARMS, & BRACHYTHERAPIES)            *
      *   - SCH ADJUSTMENT APPLIED TO BLOOD & BRACHY LINES          *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      * - 11/12/2008 - FOR CY 2009, BRACHYS NOT PROCESSED IN THIS   *
      *   PARAGRAPH; BRACHY LINES ASSIGNED A NEW SI OF ' U'         *
      * - 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES HAVE A   *
      *   SI = R                                                    *
      * - 12/05/2008 - MODIFIED LOGIC TO SEND BLOOD LINES WITHOUT   *
      *   A PMT ADJ FLAG = 5 OR 6 TO THE SCH ADJUSTMENT PARAGRAPH,  *
      *   INCLUDED SI = R IN THE BLOOD IDENTIFICATION LOGIC         *
      * - 11/15/2009 - BRACHYTHERPY SERVICES (SI = U) & THERAPEUTIC *
      *   RADIOPHARMS (SI = K) SENT TO THIS PARAGRAPH FOR CY 2010,  *
      *   LOGIC ALTERED TO PROCESS SI = U (RECEIVE REGULAR APC PMT) *
      * - 11/17/2009 - SEND BRACHYTHERAPY LINES TO 10550-SCH-ADJ TO *
      *   MAKE ELIGIBLE FOR SCH ADJUSTMENT, NOT WAGE ADJUSTED       *
      * - 05/10/2016 - ADDED LOGIC FOR SPECIAL HANDLING OF BLOOD    *
      *   DEDUCTIBLE LINES ON CLAIMS WITH A COMPREHENSIVE APC       *
      *                                                             *
      ***************************************************************
       15550-CALC-GJK.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 15550-SET-BLOOD-FRACTION
                     THRU 15550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 15550-ADJ-BLOOD-COST
                     THRU 15550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 15550-SCH-ADJ
                     THRU 15550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * CHANGE THE PAYMENT OF THE BLOOD DEDUCTIBLE LINE ON THE SAME *
      * CLAIM AS A COMPREHENSIVE APC TO THE BLOOD DEDUCTIBLE AMOUNT *
      *-------------------------------------------------------------*
                  IF PKG-BLD-DED-LINE
                      MOVE H-LN-BLOOD-DEDUCT TO H-LITEM-PYMT
                  END-IF

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE, BUT PAF = 5 OR 6           *
      * (BLOOD PROCESSING AND PRODUCT BILLED TOGETHER)              *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 15550-ADJ-PLATE-COST
                      THRU 15550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 15550-SCH-ADJ
                      THRU 15550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE AND PAF NOT EQUAL TO 5 OR 6 *
      * (ONLY BLOOD PRODUCT BILLED)                                 *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 12/05/2008 - 7550-SCH-ADJ PERFORM ADDED FOR BLOOD LINES     *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 15550-SCH-ADJ
                      THRU 15550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      *    CALCULATE LINE ITEM PAYMENT FOR DRUGS, BIOLOGICALS,      *
      *    BRACHYTHERAPY SERVICES, & THERAPEUTIC RADIOPHARMS        *
      *                                                             *
      ***************************************************************
                ELSE
                   IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                      COMPUTE H-LITEM-PYMT ROUNDED =
                       W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                        * W-DISC-RATE (W-LP-INDX)
                   ELSE
                      IF OPPS-SRVC-IND (LN-SUB) = ' U'
                         PERFORM 15550-SCH-ADJ
                            THRU 15550-SCH-ADJ-EXIT
                      END-IF
                   END-IF
                END-IF
             END-IF
             END-IF.

       15550-CALC-GJK-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       15550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       15550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       15550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       15550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       15550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       15550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      ADJUST THE PASS-THROUGH RADIOPHARM PAYMENT BY          *
      *      ITS PROPORTION OF THE NUCLEAR MEDICINE OFFSET          *
      *                                                             *
      *      EFFECTIVE 04/01/2009, LOGIC ADDED 02/11/2009           *
      *                                                             *
      ***************************************************************
       15550-PTRADIO-OFFSET.

      *-------------------------------------------------------------*
      * CALCULATE PROPORTION OF TOTAL OFFSET TO BE APPLIED TO LINE  *
      *-------------------------------------------------------------*
      * 12/20/2009 - ADDED LOGIC TO PREVENT DIVISION BY ZERO ERROR  *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             IF H-PTRADIO-TOT-CHRGS > 0 THEN
                COMPUTE W-PTRADIO-CHRG-RATE ROUNDED =
                        H-SUB-CHRG / H-PTRADIO-TOT-CHRGS
             ELSE
                MOVE 0 TO W-PTRADIO-CHRG-RATE
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE APPLIED TO LINE           *
      *-------------------------------------------------------------*
             COMPUTE W-PTRADIO-LINE-OFFSET ROUNDED =
                     H-NUCMED-TOT-OFFSET * W-PTRADIO-CHRG-RATE.

      *-------------------------------------------------------------*
      * SUBTRACT THE APPLICABLE OFFSET FROM THE LINE PAYMENT        *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-PYMT ROUNDED =
                     H-LITEM-PYMT - W-PTRADIO-LINE-OFFSET.

       15550-PTRADIO-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      ADJUST THE PASS-THROUGH CONTRAST AGENT PAYMENT BY      *
      *   ITS PROPORTION OF THE PT CONTRAST AGENT PROCEDURE OFFSET  *
      *                                                             *
      *      EFFECTIVE 01/01/2010, LOGIC ADDED 11/16/2009           *
      *                                                             *
      ***************************************************************
       15550-PTCA-OFFSET.

      *-------------------------------------------------------------*
      * CAPTURE LINE DATE OF SERVICE                                *
      *-------------------------------------------------------------*
             MOVE OPPS-LITEM-DOS (LN-SUB) TO W-CAPROC-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT CONTRAST AGENT DAY TABLE FOR DATE OF SERVICE      *
      *-------------------------------------------------------------*
             SET W-PTCA-DAY-INDX TO 1.

             SEARCH W-PTCA-DAY-ENTRY

      *-------------------------------------------------------------*
      * DATE OF SERVICE NOT FOUND IN TABLE, STOP PROCESS            *
      *-------------------------------------------------------------*
                AT END
                   GO TO 15550-PTCA-OFFSET-EXIT

      *-------------------------------------------------------------*
      * DATE OF SERVICE FOUND IN TABLE, TAKE OFFSET                 *
      *-------------------------------------------------------------*
                WHEN W-PTCA-DAY-LIDOS (W-PTCA-DAY-INDX) =
                     W-CAPROC-SRVC-DATE

      *-------------------------------------------------------------*
      * CALCULATE PROPORTION OF TOTAL OFFSET TO BE APPLIED TO LINE  *
      *-------------------------------------------------------------*
      * 12/20/2009 - ADDED LOGIC TO PREVENT DIVISION BY ZERO ERROR  *
      *-------------------------------------------------------------*
                     MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                     IF W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX) > 0
                        COMPUTE W-PTCA-CHRG-RATE ROUNDED =
                                H-SUB-CHRG /
                                W-PTCA-DAY-TOT-CHRGS (W-PTCA-DAY-INDX)
                     ELSE
                        MOVE 0 TO W-PTCA-CHRG-RATE
                     END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE APPLIED TO LINE           *
      *-------------------------------------------------------------*
                     COMPUTE W-PTCA-LINE-OFFSET ROUNDED =
                         W-PTCA-DAY-TOT-OFFSET (W-PTCA-DAY-INDX) *
                         W-PTCA-CHRG-RATE

      *-------------------------------------------------------------*
      * SUBTRACT THE APPLICABLE OFFSET FROM THE LINE PAYMENT        *
      *-------------------------------------------------------------*
                     IF H-LITEM-PYMT >= W-PTCA-LINE-OFFSET
                        COMPUTE H-LITEM-PYMT ROUNDED =
                                H-LITEM-PYMT - W-PTCA-LINE-OFFSET
                     ELSE
                        MOVE 0 TO H-LITEM-PYMT
                     END-IF
             END-SEARCH.

       15550-PTCA-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *           CALCULATE PAYMENT FOR PAID AT COST LINES          *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 08-11-2010 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED       *
      * 11-17-2015 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED AGAIN *
      *                                                             *
      ***************************************************************
       15555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST - "PAID AT COST"         *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).

      *-------------------------------------------------------------*
      * FOR PASS-THROUGH DEVICE LINE WITH AN ASSOCIATED OFFSET,     *
      * APPLY THE OFFSET (INDICATED BY PAF = '12' OR '13' OR '15'   *
      *-------------------------------------------------------------*
              IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12' OR
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13' OR
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
                 PERFORM 15556-CALC-PTD-OFFSET
                    THRU 15556-CALC-PTD-OFFSET-EXIT
              END-IF.

      *-------------------------------------------------------------*
      * CAPTURE PAYMENT AMOUNT                                      *
      *-------------------------------------------------------------*
             IF T-LITEM-PYMT < 0 THEN
                MOVE 0 TO H-LITEM-PYMT
             ELSE
                MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

       15555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *   REDUCE LINE ITEM PAYMENTS OF PASS-THROUGH DEVICES THAT    *
      * HAVE AN ASSOCIATED PROCEDURE ON THE CLAIM BY THE PROCEDURE  *
      *                WAGE-ADJUSTED OFFSET AMOUNT                  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ** EFFECTIVE 11/13/2015 - REVISED PT DEVICE OFFSET LOGIC    *
      *                                                             *
      ***************************************************************
       15556-CALC-PTD-OFFSET.

      *-------------------------------------------------------------*
      * DETERMINE WHICH VARIABLES TO USE IN CALCULATIONS            *
      *-------------------------------------------------------------*
            INITIALIZE H-TOT-PTD-CHARGES
                       H-WA-PTD-OFFSET.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
               MOVE H-QN-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QN-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
               MOVE H-QO-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QO-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *     IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *        MOVE H-QP-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
      *        MOVE H-QP-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
      *     END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHAT % OF THE OFFSET WILL BE APPLIED              *
      *-------------------------------------------------------------*
            IF H-TOT-PTD-CHARGES > 0
               COMPUTE W-PTDO-CHRG-RATE ROUNDED =
                       H-SUB-CHRG / H-TOT-PTD-CHARGES
            ELSE
               GO TO 15556-CALC-PTD-OFFSET-EXIT
            END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE TAKEN                     *
      *-------------------------------------------------------------*
            COMPUTE W-PTDO-LINE-OFFSET ROUNDED =
                    W-PTDO-CHRG-RATE *
                    H-WA-PTD-OFFSET.

      *-------------------------------------------------------------*
      * SUBTRACT THE OFFSET AMOUNT FROM THE LINE PAYMENT            *
      *-------------------------------------------------------------*
            IF W-PTDO-LINE-OFFSET <= T-LITEM-PYMT
               COMPUTE T-LITEM-PYMT ROUNDED =
                       T-LITEM-PYMT - W-PTDO-LINE-OFFSET
            ELSE
               MOVE 0 TO T-LITEM-PYMT
            END-IF.


       15556-CALC-PTD-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       15560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * LINES INELIGIBLE FOR DEDUCTIBLE SKIP DEDUCTIBLE CALCULATION *
      * EFF. 7/1/2009 - CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      * ASSIGNED A PAF = ' 4'                                       *
      * - 04/11/2011 - ADDED PAF 9 FOR SERVICES WHERE THE           *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *   (ADDED FOR PREVENTIVE SERVICES WAIVER IN CY 2011)         *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 4' OR ' 9')
                GO TO 15560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       15560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      * - 11/12/2008: FOR CY 2009, BRACHYS SI = U AND BLOOD SI = R  *
      *   BRACHY INELIGIBLE FOR OUTLIER, BLOOD ELIGIBLE FOR OUTLIER *
      *                                                             *
      * - 12/05/2008: ADDED SI = K TO LIST OF SIS INELIGIBLE FOR    *
      *   OUTLIER (BRACHYS & BLOOD NO LONGER HAVE SI = K)           *
      *                                                             *
      * - 11/17/2009: REMOVED U FROM LIST OF SIS INELIGIBLE FOR     *
      *   OUTLIER; BRACHYS NOW ELIGIBLE B/C NOT PAID AT COST CY 2010*
      *                                                             *
      * - 12/16/2009: ADDED SIS R AND U TO LOGIC THAT DISTRIBUTES   *
      *   PACKAGED CHARGES TO PAYABLE LINES. V2010.1.2              *
      *                                                             *
      * - 11/04/2011: MODIFIED LOGIC TO APPLY THE PHP CAP ONLY TO   *
      *   PHP CMHC LINES, NOT PHP HOSPITAL LINES PER POLICY'S       *
      *   INSTRUCTIONS                                              *
      *                                                             *
      * - 11/17/2015: MODIFIED LOGIC TO STOP ACCOUNTING FOR         *
      *   PASS-THROUGH DEVICE PAYMENTS AND CHARGES IN ASSOCIATED    *
      *   PROCEDURE'S OUTLIER CALCULATION.  ADDED STATUS INDICATOR  *
      *   'J2' AS ELIGIBLE FOR OUTLIER AND TO RECEIVED PACKAGED     *
      *   CHARGES                                                   *
      *                                                             *
      * - 05/10/2016: ADDED LOGIC TO EXCLUDE LINES ELIGIBLE FOR THE *
      *   BLOOD DEDUCTIBLE AND ON A CLAIM WITH A COMPREHENSIVE APC  *
      *   FROM THE OUTLIER PAYMENT                                  *
      *                                                             *
      ***************************************************************
       15600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * LINES WITH SERVICE INDICATORS NOT ELIGIBLE FOR AN OUTLIER   *
      * PAYMENT AND LINES PACKAGED AS PART OF DRUG ADMINISTRATION   *
      * APC PAYMENT BYPASS OUTLIER CALCULATION                      *
      * (DRUGS, DEVICES, PACKAGED SERVICES, BIOLOGICALS)            *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW THAT DISTRIBUTES PACKAGED *** *
      * *** CHARGES TO PAYABLE LINES AND IN THE SUMMING LOGIC   *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * 11/12/2008 - BRACHY (SI=U) ADDED TO LIST                    *
      * 12/05/2008 - SI K ADDED TO THE LIST                         *
      * 11/16/2009 - REMOVED PAF=2 FROM BRACHY (SI=U) CRITERIA      *
      * 11/17/2009 - REMOVE SI=U, BRACHYS ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR ' N' OR
                                          ' K') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4')
                   GO TO 15600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * BLOOD LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND ON A      *
      * CLAIM WITH A COMPREHENSIVE APC NOT ELIGIBLE FOR OUTLIER     *
      *-------------------------------------------------------------*
      * 05/10/2016 - NEW FOR JULY 2016                              *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  GO TO 15600-ADJ-CHRG-OUTL-EXIT
             END-IF.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                           ' X' OR ' P' OR ' R' OR
                                           ' U' OR 'J1' OR 'J2') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                          ' X' OR ' P' OR ' R' OR
                                          ' U' OR 'J1' OR 'J2') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A COMPOSITE ADJ.     *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 01 - NN...) ARE ACCUMULATED BY COMPOSITE            *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME        *
      * (PAYABLE) LINE'S CHARGES.                                   *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2007 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      * 11/12/2008 - CHANGED LOGIC TO USE THE COMPOSITE ADJUSTMENT  *
      *              FLAG INSTEAD OF THE PAYMENT ADJUSTMENT FLAG    *
      *              VALUES 91 - 99 TO ID PRIME COMPOSITE LINES     *
      ***************************************************************

      *-------------------------------------------------------------*
      * COMPOSITE ADJUSTMENT FLAG > 0 INDICATES COMPOSITE APC       *
      *-------------------------------------------------------------*
           IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = '00'

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.


      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD                          *
      *   (ALWAYS USE THE PHP "CAP" APC'S WAGE ADJ PMT FOR PHP LINES*
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED BECAUSE PAYMENTS MAY BE ADJUSTED FOR     *
      *              PASS-THROUGH DEVICES                           *
      * ??/??/2008 - NEW FOR CY 2009 - ALWAYS USE THE PHP "CAP"     *
      *              APC'S WAGE ADJ "CAP" PMT FOR PHP LINES (SI=P)  *
      * 11/04/2011 - ONLY APPLY PHP "CAP" TO CMHC LINES; PER        *
      *              POLICY'S INSTRUCTIONS PHP HOSPITAL LINES ARE   *
      *              NOT CAPPED.                                    *
      * 11/17/2015 - CONTINUE TO USE THIS LOGIC EVEN THOUGH PAYMENTS*
      *              ARE NO LONGER ADJUSTED FOR PT DEVICES          *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           IF OPPS-SRVC-IND (LN-SUB) = ' P' AND
              ( (L-PSF-PROV-3456 >= '1400' AND
                 L-PSF-PROV-3456 <= '1499') OR
                (L-PSF-PROV-3456 >= '4600' AND
                 L-PSF-PROV-3456 <= '4799') OR
                (L-PSF-PROV-3456 >= '4900' AND
                 L-PSF-PROV-3456 <= '4999') )
              MOVE H-PHP-LITEM-PYMT-OUTL TO H-LITEM-PYMT-OUTL
           ELSE
              MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL
           END-IF.


      ***************************************************************
      *                                                             *
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      * -NEW FOR JANUARY 2009                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE PHP "CAP" APC'S LINE PAYMENT                        *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      * (CMHC PROVIDERS ONLY PROCESS PARTIAL HOSPITALIZATION LINES) *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT


      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE

                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 3250)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT
                  END-IF

               END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       15600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 15550-CALC-GJK &       *
      *      15550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES        *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       15655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9056' OR
                                    'P9021' OR
                                    'P9016' OR
                                    'P9051' OR
                                    'P9057' OR
                                    'P9038' OR
                                    'P9010' OR
                                    'P9058' OR
                                    'P9040' OR
                                    'P9022' OR
                                    'P9054' OR
                                    'P9039'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       15655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE LINE HCPCS IS A CURRENT PASS-THROUGH *
      *                 RADIOPHARMACEUTICAL HCPCS                   *
      *                                                             *
      *    - IF SO: SET PTRADIO-LINE-FLAG = 'Y',                    *
      *             ADD 1 TO COUNT OF TOTAL PT RADIOPHARMS,         *
      *             ADD CHARGES TO CLAIM TOTAL PT RADIOPHARM CHRGES *
      *    - THIS FLAG IS USED IN PARAGRAPHS 15125-INIT &           *
      *      15550-CALC-STANDARD TO PROCESS PT RADIOPHARM LINES     *
      *                                                             *
      *  ** PASS-THROUGH RADOIOPHARM TABLE IS UPDATED QUARTERLY     *
      *  (CODE NEW FOR CY2009; ADDED 02/10/2009)                    *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      *  12/20/2011 - LOGIC REVISED TO INCLUDE TERMINATION DATE     *
      *               AS A VALID DATE OF SERVICE                    *
      *                                                             *
      ***************************************************************
       15680-SET-PTRADIO-LINE-FLAG.

           MOVE 'N' TO PTRADIO-LINE-FLAG.

           SEARCH ALL PTRH-ENTRY
            AT END
             MOVE 'N' TO PTRADIO-LINE-FLAG

            WHEN PTRH-PTRADIO-HCPCS (PTRH-INDX) = OPPS-HCPCS (LN-SUB)
             IF OPPS-LITEM-DOS (LN-SUB) >= PTRH-EFF-DATE (PTRH-INDX) AND
               (OPPS-LITEM-DOS (LN-SUB) <= PTRH-TERM-DATE (PTRH-INDX) OR
                PTRH-TERM-DATE (PTRH-INDX) = 0) THEN
                MOVE 'Y' TO PTRADIO-LINE-FLAG
             END-IF.

       15680-SET-PTRADIO-LINE-FL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE LINE HCPCS IS A CURRENT PASS-THROUGH *
      *                     CONTRAST AGENT HCPCS                    *
      *                                                             *
      *    - IF SO: SET PTCA-LINE-FLAG = 'Y',                       *
      *    - THIS FLAG IS USED IN PARAGRAPHS 15125-INIT &           *
      *      15550-CALC-STANDARD TO PROCESS PT CONTRAST AGENT LINES *
      *                                                             *
      *  ** PASS-THROUGH CONTRAST AGENT TABLE IS UPDATED QUARTERLY  *
      *  (CODE NEW FOR CY2010; ADDED 11/16/2009)                    *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      *  12/20/2011 - LOGIC REVISED TO INCLUDE TERMINATION DATE     *
      *               AS A VALID DATE OF SERVICE                    *
      *                                                             *
      ***************************************************************
       15681-SET-PTCA-LINE-FLAG.

           MOVE 'N' TO PTCA-LINE-FLAG.

           SEARCH ALL PTCH-ENTRY
            AT END
             MOVE 'N' TO PTCA-LINE-FLAG

            WHEN PTCH-PTCONTR-HCPCS (PTCH-INDX) = OPPS-HCPCS (LN-SUB)
             IF OPPS-LITEM-DOS (LN-SUB) >= PTCH-EFF-DATE (PTCH-INDX) AND
               (OPPS-LITEM-DOS (LN-SUB) <= PTCH-TERM-DATE (PTCH-INDX) OR
                PTCH-TERM-DATE (PTCH-INDX) = 0) THEN
                MOVE 'Y' TO PTCA-LINE-FLAG
             END-IF.

       15681-SET-PTCA-LINE-FL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            PROCESS DRUG COINSURANCE TABLE RECORDS           *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE "DRUG" LINE COINSURANCE WHEN THE PROCEDURE      *
      *  COINSURANCE AMOUNTS PLUS THE "DRUG" COINSURANCE AMOUNT(S)  *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       15800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 15810-PROCESS-TYPE1
                   THRU 15810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 15840-PROCESS-TYPE2
                   THRU 15840-PROCESS-TYPE2-EXIT.

       15800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH "DRUG" COINSURANCE, DETERMINE THE *
      *  % OF TOTAL "DRUG" COINSURANCE THAT CAN BE PAID IN ADDITION *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE DRUG COINSURANCE CAN BE PAID *
      *  WHEN H-RATIO = 1, ALL OF THE DRUG COINSURANCE CAN BE PAID  *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       15810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * DRUGS WERE ADMINISTERED ON THE DAY                          *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & WAGE ADJUSTED COINSURANCE OF THE      *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL DRUG COIN THAT CAN BE    *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S DRUG COIN CAN BE PAID B/C THE PROCEDURE/  *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL DRUG COINSURANCE CAN BE PAID WITHIN THE     *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       15810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE "DRUG" LINE'S NATIONAL COINSURANCE AMOUNT AND   *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       15840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 DRUG COIN REC HAS SAME DATE OF SERVICE AS    *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE DRUG COIN RECORD *
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE DRUG LINE BY   *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD DRUG COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT    *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       15840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       15900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       15900-END-PRICE-RTN-EXIT.
           EXIT.




      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 16000 FOR CALENDAR YEAR 2017 PROCESSING        **
      **          SERVICE FROM DATES: 1/1/2017 - 12/31/2017           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE IOCE)      *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  7. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  8. CALCULATE SERVICE LINE PAYMENTS                            *
      *  9. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 10. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 11. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 12. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 13. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, AND COMPOSITE *
      *     CHARGES OF APPLICABLE PROCEDURES.                          *
      *     ALL ADJUSTMENTS ARE DONE FOR OUTLIER DETERMINATION ONLY.   *
      * 14. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 15. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR BLOOD LINES; *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE BLOOD LINE'S REIMBURSEMENT                    *
      * 17. ACCUMULATE CLAIM TOTALS                                    *
      * 18. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       16000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY),  *
      *            DETERMINE CLAIM DEVICE CREDIT AMOUNT               *
      *            (CLAIM LEVEL INITIALIZATION)                       *
      *                                                               *
      *****************************************************************
              PERFORM 16100-INIT
                 THRU 16100-INIT-EXIT.

      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - C-APC-CLAIM-FLAG - COMPREHENSIVE APC ON CLAIM - FOR       *
      *     SPECIAL BLOOD DEDUCTIBLE LINE LOGIC                       *
      *                                                               *
      *****************************************************************
              PERFORM 16125-INIT
                 THRU 16125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.



      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH *
      *            RADIOPHARMACEUTICAL OFFSET, CREATE CONTRAST        *
      *            AGENT PROCEDURE TABLE FOR PASS-THROUGH CONTRAST    *
      *            AGENT OFFSET.                                      *
      *            (LOOP THROUGH THE CLAIM LINES)                     *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY TABLES FOR NEW CLAIM                             *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX    W-BLD-MAX    W-CMP-MAX.

              PERFORM 16150-INIT
                 THRU 16150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      *-------------------------------------------------------------*
      * CALCULATE WAGE-ADJUSTED PASS-THROUGH DEVICE OFFSETS         *
      * (VALUE CODES QN, QO & QP; CLAIM LEVEL)                      *
      * NEW FOR CY2016 - 11/13/2015                                 *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QN > 0
                COMPUTE H-QN-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QN * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QN * .40)
             END-IF.

             IF L-PAYER-ONLY-VC-QO > 0
                COMPUTE H-QO-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QO * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QO * .40)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF L-PAYER-ONLY-VC-QP > 0
      *         COMPUTE H-QP-WA-PTD-OFFSET ROUNDED =
      *                 ((L-PAYER-ONLY-VC-QP * .60) * H-WINX) +
      *                 (L-PAYER-ONLY-VC-QP * .40)
      *      END-IF.



      *****************************************************************
      *                                                               *
      *   STEP 4 - INITIALIZE W-DCP-MAX                               *
      *   ------                                                      *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, AND MOVE LINE ITEM         *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 16400-CALCULATE
                 THRU 16400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, AND COMPOSITES, AND CALCULATE  *
      *            OUTLIER PAYMENTS                                   *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 16600-ADJ-CHRG-OUTL
                 THRU 16600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.
              PERFORM 16610-CMHC-OUTL-CAP
                 THRU 16610-CMHC-OUTL-CAP-EXIT.

      *****************************************************************
      *                                                               *
      *   STEP 7 - RECALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS*
      *   ------   FOR STATUS INDICATOR R (BLOOD) LINES WHEN THE DAILY*
      *            INPATIENT DEDUCTIBLE CAP IS EXCEEDED.              *
      *            THE COINSURANCE CAP IS APPLIED USING THE WAGE      *
      *            ADJUSTED NATIONAL COINSURANCE OF EACH DAY'S MOST   *
      *            EXPENSIVE PROCEDURE OR VISIT.                      *
      *            (LOOP THROUGH THE COINSURANCE CAP ROLL-UP TABLE)   *
      *                                                               *
      *****************************************************************
                IF BLOOD-FLAG = 'Y'
                   PERFORM 16800-ADJ-STV-REIM
                      THRU 16800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                END-IF.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 16900-END-PRICE-RTN
                 THRU 16900-END-PRICE-RTN-EXIT.

       16000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY DEDUCTIBLE CAP (H-IP-LIMIT)            *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       16100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE FLAGS AND VARIABLES               *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 11/03/2008 - APC33-FLAG REPLACED BY PHP-APC-FLAG            *
      * 11/12/2008 - BRACHY-APC-FLAG REMOVED, NOT USED FOR CY 2009  *
      * 02/09/2009 - PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG ADDED    *
      * 11/16/2009 - RADIOPH-APC-FLAG REMOVED; PTCA-CLAIM-FLAG,     *
      *              PTCA-LINE FLAG ADDED                           *
      * 02/07/2012 - BILL14X-FLAG REMOVED                           *
      * 11/18/2013 - DEVCR-CLAIM-FLAG ADDED                         *
      * 11/17/2015 - REMOVED APC34-FLAG (MENTAL HEALTH), PTD-FLAG,  *
      *              PTD-LINE-FLAG, PTD-PROC-FLAG, AND              *
      *              C1820-OFFSET-FLAG BECAUSE THEY'RE NOT USED     *
      * 02/09/2016 - ADD LOGIC TO DETERMINE CLAIM'S DEVICE CREDIT   *
      * 02/10/2016 - DEVCR-CLAIM-FLAG REMOVED (NO LONGER USED)      *
      * 10/26/2016 - PHP-HCPCS-FLAG, MH-HCPCS-FLAG,                 *
      *              PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG,         *
      *              PTCA-CLAIM-FLAG, PTCA-LINE-FLAG REMOVED        *
      *              (NO LONGER USED)                               *
      *                                                             *
      *-------------------------------------------------------------*
             MOVE 'N'   TO BLOOD-FLAG
                           ST0-FLAG
                           N-FLAG
                           BLD-DEDUC-HCPCS-FLAG
                           C-APC-CLAIM-FLAG
                           PKG-BLD-DED-LINE-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO  TO A-OUTLIER-PYMT
                           A-TOTAL-CLM-DEDUCT
                           A-TOT-CLM-CHRG
                           A-TOT-CLM-PYMT
                           A-BLOOD-DEDUCT-DUE
                           A-BLOOD-PINTS-USED
                           A-WINX
                           W-LNC-MAX
                           A-DEVICE-CREDIT-QD.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.

      *-------------------------------------------------------------*
      * INITIATILIZE WORKING STORAGE DATES - 10-23-2014             *
      *-------------------------------------------------------------*
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-BEGIN-YYYY.
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-END-YYYY.

      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 16100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 16100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 16100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION16 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE THE TOTAL DEVICE CREDIT AMOUNT TO BE DEDUCTED     *
      * FROM THE CLAIM - USE THE LESSER OF THE AMOUNT IN            *
      * VALUE CODE FD AND THE CAP AMOUNT IN VALUE CODE QU           *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QU > 0 AND
                L-DEVICE-CREDIT > 0
                IF L-PAYER-ONLY-VC-QU < L-DEVICE-CREDIT
                   MOVE L-PAYER-ONLY-VC-QU TO H-CLAIM-DEVCR-AMT
                ELSE
                   MOVE L-DEVICE-CREDIT TO H-CLAIM-DEVCR-AMT
                END-IF
             END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
      *-------------------------------------------------------------*
      *   USE SPECIAL WAGE INDEX WHEN INDICATED                     *
      *   (PSF RECORD EFFECTIVE DATE MUST BE WITHIN THE CLAIM'S CY) *
      *   ADDED 10-23-2014 FOR CY 2015                              *
      *-------------------------------------------------------------*
                   IF (L-PSF-SPEC-PYMT-IND = '1' OR '2') AND
                      (L-PSF-EFFDT >= W-CY-BEGIN-DATE AND
                       L-PSF-EFFDT <= W-CY-END-DATE)
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX
                      MOVE 1316 TO H-IP-LIMIT
                      GO TO 16100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 16100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 16100-INIT-EXIT.

             MOVE 1316 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      * APPLY WAGE INDEX FLOOR POLICY                               *
      * (USE HIGHER OF CBSA WAGE INDEX AND STATE RURAL WAGE INDEX)  *
      *-------------------------------------------------------------*
      * 10-23-2014 - NEW FLOOR LOGIC FOR CY 2015                    *
      * 10-28-2015 - NEW STATE CODES ADDED FOR APRIL 2016           *
      *-------------------------------------------------------------*

      *-------------------------------------------------------------*
      * >FIRST, CONFIRM FLOOR SWITCH IS SET                         *
      *-------------------------------------------------------------*
             SET W-FLOOR-LOOKUP TO TRUE.

      *-------------------------------------------------------------*
      * >GET PROVIDER'S STATE CODE FOR RURAL FLOOR WAGE INDEX       *
      *  LOOK-UP (NEW FOR JULY 2016)                                *
      *-------------------------------------------------------------*
             MOVE L-PSF-STATE-CODE TO W-PSF-PROV-ST.

      *-------------------------------------------------------------*
      * >NOW, CALL WAGE INDEX LOOKUP AND LOOK FOR THE STATE FLOOR.  *
      *  STORE PSF-CBSA IN A-CBSA (IT GETS MOVED THERE IN THE NEXT  *
      *  STEP ANYWAY). THIS FREES H-PSF-CSBA FOR THE FLOOR SEARCH   *
      *  MOVE THREE SPACES + STATE CODE TO H-PSF-CBSA               *
      *  STORE RESULT IN H-WINX.                                    *
      *  MOVE A-CBSA BACK TO H-PSF-CBSA FOR CLEANUP                 *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             STRING '   ' DELIMITED BY SIZE
                   W-PSF-PROV-ST DELIMITED BY SIZE
                   INTO H-PSF-CBSA.
             PERFORM 16200-CALC-WAGEINDX
                THRU 16200-CALC-WAGEINDX-EXIT.
             MOVE A-CBSA TO H-PSF-CBSA.

      *-------------------------------------------------------------*
      * >GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN   *
      *  BY THE PSF SPECIAL WAGE INDEX VALUE)                       *
      *                                                             *
      *   NOTE: IF PSF SPECIAL WAGE INDEX VALUE USED,               *
      *         15100-INIT-EXIT WILL BE CALLED ABOVE - THIS CODE    *
      *         WILL NEVER BE REACHED. THEREFORE CHECKING FOR A 0   *
      *         VALUE SHOULD BE UNNECESSARY.                        *
      * >SET WAGE INDEX LOOKUP FLAG (FLOOR FLAG = 'N')              *
      *-------------------------------------------------------------*
             SET W-WINX-LOOKUP TO TRUE.

                PERFORM 16200-CALC-WAGEINDX
                   THRU 16200-CALC-WAGEINDX-EXIT.



       16100-INIT-EXIT.
           EXIT.





      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND APC / HCPCS/ FLAGS  *
      *                                                             *
      *  - SET FLAG IF APC = 5851/5852/5861/5862 (PARTIAL HOSP.)    *
      *  - SET FLAG IF PASS-THROUGH RADIOPHARMS(S) ON CLAIM         *
      *    (NEW FOR APRIL CY 2009 - ADDED 02/10/2009)               *
      *  - SET FLAG IF PASS-THROUGH CONTRAST AGENT(S) ON CLAIM      *
      *    (NEW FOR JANUARY CY 2010 - ADDED 11/15/2009)             *
      *  - SET FLAG IF CLAIM IS ELIGIBLE FOR DEVICE CREDIT          *
      *    (NEW FOR JANUARY CY 2014)                                *
      *  - SET FLAG IF CLAIM HAS A COMPREHENSIVE APC (C-APC) LINE   *
      *    (NEW FOR JULY 2016)                                      *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION HCPCS FROM     *
      *              0033 TO 0172 & 0173 FOR CY 2009                *
      *                                                             *
      * 11/12/2008 - HCPCS C1820 EXPIRED FROM PASS-THROUGH STATUS   *
      *              DECEMBER 2007, OFFSET FLAG LOGIC DISABLED      *
      *                                                             *
      * 08/02/2010 - ADDED LOGIC TO SET PASS-THOUGH DEVICE FLAG FOR *
      *              DEVICE OFFSETS AND POPULATE THE CORRESPONDING  *
      *              TABLE                                          *
      *                                                             *
      * 11/15/2010 - ADDED APCS 0175 & 0176 TO LIST OF PHP APCS     *
      *                                                             *
      * 11/18/2013 - ADDED LOGIC TO SET DEVICE CREDIT CLAIM FLAG    *
      *                                                             *
      * 11/17/2015 - REMOVED LOGIC TO SET FLAGS FOR PASS-THROUGH    *
      *              DEVICES (FOR OUTLIER & OFFSET LOGIC)           *
      *            - UPDATED PHP APCS FOR 2016                      *
      *            - REMOVED APC34-FLAG (MENTAL HEALTH) - NOT USED  *
      *            - REMOVED APC 0339 UNITS OVERRIDE                *
      *                                                             *
      * 05/09/2016 - ADDED LOGIC TO SET COMPREHENSIVE APC CLAIM FLAG*
      * 10/26/2016 - REMOVED PHP APC CHECK, PT RADIOPHARM CHECK,    *
      *              AND PT CONTRAST AGENT CHECK                    *
      *                                                             *
      ***************************************************************
       16125-INIT.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A COMPREHENSIVE APC     *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = 'J1' OR
                OPPS-SRVC-IND (LN-SUB) = 'J2'
                MOVE 'Y' TO C-APC-CLAIM-FLAG
             END-IF.


       16125-INIT-EXIT.
           EXIT.




      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0, 6, 7, OR 8  *
      *                (PAYMENT METHOD FLAG)                        *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       16150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 16250-CALC-DISCOUNT
                THRU 16250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 16150-INIT-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 10/26/2016 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG REMOVED         *
      *-------------------------------------------------------------*
             MOVE 'N' TO PKG-BLD-DED-LINE-FLAG.


      ***************************************************************
      *   IDENTIFY LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE ON       *
      *   A CLAIM WITH A COMPREHENSIVE APC; TREAT AS PACKAGED LINE  *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      ***************************************************************
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             END-IF.


      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR ' L' OR
                ' N' OR ' P' OR ' R' OR ' S' OR ' T' OR ' U' OR
                ' V' OR ' X' OR ' W' OR ' Y' OR ' Z' OR ' M' OR
                'J1' OR 'J2')
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 16150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' K' OR ' L' OR ' W' OR
                ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 16150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      * 10/26/2016- REMOVED PHP/MENTAL HEALTH CODE LISTS            *
      * 01/19/2017- ADDED '3' INTO LOGIC, FOR FISS INFORMATINAL USE *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF  OPPS-LITEM-DR-FLAG (LN-SUB) = ('0' OR '3') OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                       OPPS-LITEM-ACT-FLAG (LN-SUB) = '1'



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      * 11/03/2008 - REMOVED PAFS 91 - 99 FOR COMPOSITES FOR CY 2009*
      * 04/11/2011 - ADDED ' 9' & '10' AS VALID PAFS FOR CY 2011    *
      * 12/18/2014 - ADDED '11' FOR CY 2015                         *
      * 11/10/2015 - ADDED '12' - '14' FOR CY 2016                  *
      * 02/05/2016 - ADDED '16' - '20' FOR CY 2016                  *
      *              (PAF '15' RESERVED FOR FUTURE USE)             *
      * 08/11/2016 - ADDED '21' FOR CY 2016                         *
      * 01/08/2019 - ADDED '23' FOR CY 2017 RETRO ACTIVE            *
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8' OR ' 9' OR '10' OR '11'
                             OR '12' OR '13' OR '14'         OR '16'
                             OR '17' OR '18' OR '19' OR '20' OR '21'
                             OR '23'

      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *                                                             *
      *   ** SITE OF SERVICE FLAG = PAYMENT METHOD FLAG IN OCE **   *
      *                                                             *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', PHP APC IS ON THE CURRENT LINE       *
      *-------------------------------------------------------------*
      * 11/06/2007 - CHANGED PHP HEALTH CODES LISTED FROM           *
      *              APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008   *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION APC FROM       *
      *              0033 TO 0172 & 0173 FOR CY 2009, FLAG CHANGED  *
      *              FROM APC33-FLAG TO PHP-APC-FLAG                *
      * 10/19/2016 - ADDED VALUES '7' AND '8' FOR SECTION 603       *
      *              SERVICE LINES (MODIFIER 'PN')                  *
      * 10/26/2016 - REMOVED PHP SPECIFIC LOGIC                     *
      * 03/02/2017 - ADD PMF FLAG '9' VALUE TO VALID LIST           *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '9')



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE ALL PACKAGED COMPOSITE LINES                      *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *   11/12/2008 - CHANGED LOGIC THAT EXCLUDES ALL COMPOSITE    *
      *                LINES & MENTAL HEALTH PKG LINES TO USE THE   *
      *                COMPOSITE ADJUSTMENT FLAG INSTEAD OF PAYMENT *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *   05/09/2016 - ADDED LOGIC TO ENSURE BLOOD DEDUCTIBLE LINES *
      *                ON CLAIMS WITH A COMPREHENSIVE APC ARE       *
      *                INCLUDED                                     *
      *-------------------------------------------------------------*
                IF ( (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                     (OPPS-COMP-ADJ-FLAG (LN-SUB) = '00') ) OR
                     PKG-BLD-DED-LINE
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED REVENUE CODE 39X BLOOD LINE CHARGES   *
      *   (BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC)      *
      *   WHEN BILLED ON CLAIM WITH A COMPREHENSIVE APC TO          *
      *   DETERMINE THE PORTION OF THE BLOOD APC PAYMENT TO BE      *
      *   DISTRIBUTED TO THE BLOOD PRODUCT (PAF = 5) LINE FOR THE   *
      *   BLOOD DEDUCTIBLE CALCULATION                              *
      *-------------------------------------------------------------*
      *   05/16/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' N' AND
               (OPPS-LITEM-RVCD (LN-SUB) = '0390' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0392' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0399')
                  COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB) +
                                          H-TOT-38X-39X
             END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME (PACKAGED) COMPOSITE APC CHARGES     *
      *   FOR EACH COMPOSITE APC BY THE COMPOSITE ADJUSTMENT FLAG   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2007 - LOGIC REVISED FOR CY 2009 TO IDENTIFY ALL    *
      *                COMPOSITE LINES USING THE COMPOSITE          *
      *                ADJUSTMENT FLAG INSTEAD OF PAYMENT           *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *                (INCLUDES PROCESSING FOR MENTAL HEALTH       *
      *                 COMPOSITES)                                 *
      *-------------------------------------------------------------*
                IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "00" AND
                   OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "  " AND
                   OPPS-SRVC-IND (LN-SUB) = ' N'
                      PERFORM 16170-COMPOSITES
                         THRU 16170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   SET RETURN CODE & EXIT WHEN PACKAGED LINE/LINE APC = 0000 *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 16150-INIT-EXIT
                END-IF


      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 16150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 16175-APC-LOOKUP

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT METHOD FLAG = '8' (603 SV)*
      *   SET THE COINSURANCE AND REIMBURSEMENT TO PFS RATES        *
      *   10/19/2016 - NEW FOR CY 2017; 50% REDUCTION               *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * PFS-REDUCT-2017
                      END-IF

                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                         COMPUTE H-MIN-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         COMPUTE H-NAT-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         MOVE    PFS-REIM-RATE TO H-PPCT
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '14' (CT SCAN) *
      *   11/10/2015 - NEW FOR CY 2016; 5% REDUCTION                *
      *   07/15/2016 - NEW FOR CY 2017; 15% REDUCTION               *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '14'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * CT-REDUCT-2017
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '21' OR '23'   *
      *   (X-RAY SV)                                                *
      *   08/11/2016 - NEW FOR CY 2017; 20% REDUCTION FOR FILM XRAY *
      *   01/08/2019 - ADDED PAF '23' RETRO ACTIVE 01/01/2017       *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ('21' OR '23')
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * XRAY-FILM-REDUCT-2017
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT BY REDUCED UPDATE RATIO WHEN APPROPRIATE   *
      *   11/13/2009 - NEW FOR CY 2009 (QUALITY)                    *
      *   10/19/2016 - EXCLUDE 603 SERVICES FROM QUALITY REDUCTION  *
      *                (PMT METHOD FLAG = 7 OR 8)                   *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8'
                         PERFORM 16180-REDUCE-APC-PYMT
                            THRU 16180-REDUCE-APC-PYMT-EXIT
                      END-IF



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 16150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 16150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 16150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 16150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 16150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 16150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF LINES ELIGIBLE FOR DEVICE CREDIT *
      * WHEN THE CLAIM'S TOTAL DEVICE CREDIT IS > $0 AND THE LINE   *
      * HAS PAYMENT ADJUSTMENT FLAG '17'                            *
      * - REVISED DEVICE CREDIT LOGIC FOR APRIL 2016                *
      ***************************************************************
             IF H-CLAIM-DEVCR-AMT > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17'
                COMPUTE H-TOT-DEVCR-PYMTS =
                        H-TOT-DEVCR-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF TERMINATED PROCEDURE LINES       *
      * ELIGIBLE FOR DEVICE OFFSET WHEN PAYER ONLY VALUE CODE QQ    *
      * IS > $0 AND THE LINE HAS PAYMENT ADJUSTMENT FLAG '16'       *
      * (LINE MODIFIER IS 73)                                       *
      * - IMPLEMENTED IN APRIL 2016                                 *
      ***************************************************************
             IF L-PAYER-ONLY-VC-QQ > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16'
                COMPUTE H-TOT-TPDO-PYMTS =
                        H-TOT-TPDO-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE LINE CHARGES OF PASS-THROUGH DEVICE LINES        *
      * ASSOCIATED WITH PAYER ONLY VALUE CODES QN AND QO            *
      * - LINES WITH PAF '12' RECEIVE OFFSET IN VALUE CODE QN       *
      * - LINES WITH PAF '13' RECEIVE OFFSET IN VALUE CODE QO       *
      * - LINES WITH PAF '15' RECEIVE OFFSET IN VALUE CODE QP       *
      * NEW FOR CY2016 - 11/13/2015                                 *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
                COMPUTE H-QN-TOT-PTD-CHARGES =
                        H-QN-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
                COMPUTE H-QO-TOT-PTD-CHARGES =
                        H-QO-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *         COMPUTE H-QP-TOT-PTD-CHARGES =
      *                 H-QP-TOT-PTD-CHARGES +
      *                 OPPS-SUB-CHRG (LN-SUB)
      *      END-IF.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                PERFORM 16300-COIN-DEDUCT
                   THRU 16300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2009.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                SET W17BD-INDX TO 1
                SEARCH W17BD-ENTRY VARYING W17BD-INDX
                   AT END
                      GO TO 16150-INIT-EXIT
                   WHEN W-2017-BLOOD-HCPCS (W17BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-2017-BLOOD-RANK (W17BD-INDX) TO H-BLOOD-RANK
                     MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                     PERFORM 16375-BLOOD-DEDUCT
                        THRU 16375-BLOOD-DEDUCT-EXIT
                    END-IF.

       16150-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH COMPOSITE          *
      *  ADJUSTMENT FLAG NOT = '00' & POPULATE COMPOSITE APC TABLE  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY COMPOSITE ADJUSTMENT FLAG (CAF) -   *
      *    LOWEST TO HIGHEST FLAG VALUE (01 - NN)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH CAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *  11/12/2008 - LOGIC REVISED FOR CY 2009 TO USE THE          *
      *               COMPOSITE ADJUSTMENT FLAG INSTEAD OF THE      *
      *               PAYMENT ADJUSTMENT FLAG, VARIABLE H-CMP-CAF   *
      *               HOLDS COMPOSITE ADJUSTMENT FLAG, VARIABLE     *
      *               W-CMP-PAF RETAINED AND NOW HOLDS THE CAF      *
      *               (RETAINED TO CONTINUE USE OF EXISTING TABLE)  *
      *                                                             *
      ***************************************************************
       16170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S COMPOSITE ADJUSTMENT FLAG FOR TABLE SEARCH   *
      *-------------------------------------------------------------*
             MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE CAF         *
      *-------------------------------------------------------------*
                PERFORM 16171-SEARCH-CAF
                   THRU 16171-SEARCH-CAF-EXIT.

       16170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       16171-SEARCH-CAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS NOT      *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 16172-ADD-ENTRY
                      THRU 16172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS ALREADY  *
      * IN THE TABLE, UPDATE THE ENTRY                              *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                   PERFORM 16173-UPDATE-ENTRY
                      THRU 16173-UPDATE-ENTRY-EXIT.

       16171-SEARCH-CAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       16172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS COMPOSITE ADJUSTMENT FLAG (CAF) - LOWEST TO HIGHEST CAF *
      *-------------------------------------------------------------*
             PERFORM 16174-STAGE-CMP-ENTRY
                THRU 16174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-CAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-CAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       16172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * COMPOSITE ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE       *
      *                                                             *
      ***************************************************************
       16173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE CAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       16173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER CAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       16174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       16174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       16175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 16175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       16175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      REDUCE APC PAYMENT OF LINES FROM PROVIDERS WITH A      *
      *      SPACE IN THE QUALITY INDICATOR FIELD OF THE OPSF       *
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      *  11/16/2010 - ADDED SI = U (BRACHY) TO LOGIC                *
      *                                                             *
      ***************************************************************
       16180-REDUCE-APC-PYMT.

      *-------------------------------------------------------------*
      *  SPECIFY LINES ELIGIBLE FOR REDUCTION                       *
      *  11/13/2019- QUALITY ADJUSTMENT EXCLUSION FOR NEW TECHNOLOGY*
      *  CATEGORY APC RANGES:                                       *
      *             - 1575-1599 (EFF. 1/1/2016)                     *
      *             - 1901-1906 (EFF. 1/1/2017)                     *
      *-------------------------------------------------------------*
             IF ( L-PSF-HOSP-QUAL-IND = ' ' )  AND

                (  (OPPS-SRVC-IND (LN-SUB) = ' P')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' R')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' S' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01491' AND
                           OPPS-GRP (LN-SUB) <= '01537') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01575' AND
                           OPPS-GRP (LN-SUB) <= '01585') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01906'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' T' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01539' AND
                           OPPS-GRP (LN-SUB) <= '01574') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01589' AND
                           OPPS-GRP (LN-SUB) <= '01599') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01906'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' U')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' V')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' X')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J1')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J2')  ) THEN

                COMPUTE H-APC-PYMT ROUNDED = H-APC-PYMT * 0.980
                MOVE 11 TO A-RETURN-CODE (LN-SUB)

             END-IF.


       16180-REDUCE-APC-PYMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       16200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   IF W-WINX-LOOKUP
                      MOVE  50  TO A-CLM-RTN-CODE
                   END-IF
                   GO TO 16200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA

      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 16210-WAGE-LOOKUP.

      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0 OR NOT NUMERIC             *
      *   *AND* NOT ON RURAL FLOOR LOOKUP                           *
      ***************************************************************

             IF (H-WINX = 0 OR H-WINX NOT NUMERIC) AND
                 W-WINX-LOOKUP THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       16200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       16210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE MEETS THE CRITERIA:       *
      *  - MUST NOT BE AFTER THE LATEST WAGE INDEX EFFECTIVE DATE   *
      *    THAT CAN BE USED BY THE CLAIM                            *
      *  - EXCEPT FOR INDIAN HEALTH PROVIDERS (CBSAS 98 AND 99),    *
      *    MUST BE WITHIN THE CLAIM'S CALENDAR YEAR                 *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD / LATEST         *
      *   EFFECTIVE DATE FOR THE CBSA)                              *
      ***************************************************************
             MOVE WCW-DTCD (W-SUB3) TO W-WCW-DTCD.

             IF W-WCW-DTCD NOT > WCD-DTCD (WCD-SUB) AND

                ( (WCD-DATE (W-WCW-DTCD) >= W-CY-BEGIN-DATE AND
                   WCD-DATE (W-WCW-DTCD) <= W-CY-END-DATE AND
                   H-PSF-CBSA NOT = '   98' AND
                   H-PSF-CBSA NOT = '   99') OR

                  (H-PSF-CBSA = '   98' OR
                   H-PSF-CBSA = '   99') )

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *   *ONLY VALID FOR WAGE INDEX LOOKUP, NOT RURAL FLOOR*       *
      *   IF WAGE INDEX > FLOOR, OVERWRITE H-WINX                   *
      *-------------------------------------------------------------*
                IF L-PSF-SPEC-PYMT-IND = 'Y' AND W-WINX-LOOKUP THEN
                   IF WCW-WINX2 (W-SUB3) > H-WINX THEN
                      MOVE WCW-WINX2 (W-SUB3) TO H-WINX
                   END-IF
      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *   IF WAGE INDEX > FLOOR OR LOOKING UP RURAL FLOOR, STORE    *
      *   RESULT IN H-WINX.                                         *
      *-------------------------------------------------------------*
                ELSE
                   IF (WCW-WINX1 (W-SUB3) > H-WINX OR W-FLOOR-LOOKUP)
                      MOVE WCW-WINX1 (W-SUB3) TO H-WINX
                   END-IF
                END-IF


      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE DID NOT MEET THE CRITERIA *
      *  - AFTER THE LATEST EFFECTIVE DATE THE CLAIM CAN USE -OR-   *
      *  - NOT WITHIN THE CLAIM'S CALENDAR YEAR AND NOT IN CBSA     *
      *    98 OR 99                                                 *
      *  GO TO THE PRIOR RECORD FOR THIS CBSA WITH AN EARLIER DATE  *
      *  IN THE CBSA WAGE INDEX TABLE.                              *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *  AGAIN AND REPEAT THE PROCESS
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 16210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      * >10-28-2014 ONLY VALID FOR WAGE INDEX PASS, NOT RURAL FLOOR *
      *-------------------------------------------------------------*
                ELSE

                   IF W-WINX-LOOKUP
                      MOVE 0 TO H-WINX
                END-IF
             END-IF.

       16210-WAGE-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       16250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 16250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       16250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       16300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 16350-STAGE-ENTRY
                THRU 16350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX      TO W-WINX (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       16300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       16350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       16350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       16375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 16385-STAGE-ENTRY
                THRU 16385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX     TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       16375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       16385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       16385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PAYMENTS, DEDUCTIBLES, REIM., & COINSURANCE,*
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       16400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 16400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 16550-CALC-STANDARD
                   THRU 16550-CALC-STANDARD-EXIT
             ELSE
                GO TO 16400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRUG COINSURANCE TABLE FOR LATER PROCESSING        *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET BLOOD-FLAG WHEN SERVICE INDICATOR = R (BLOOD)        *
      *  - EXCLUDE PACKAGED BLOOD DEDUCTIBLE LINES & SECTION 603    *
      *    SERVICE LINES                                            *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30 AND
                NOT PKG-BLD-DED-LINE AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                PERFORM 16450-ADJ-PROC-COIN
                   THRU 16450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 16500-ADJ-CHRGS
                THRU 16500-ADJ-CHRGS-EXIT.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

                COMPUTE A-DEVICE-CREDIT-QD =
                        A-DEVICE-CREDIT-QD + H-LINE-DEVCR-AMT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 15840-PROCESS-TYPE2     *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)

               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       16400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      POPULATE COINSURANCE CAP ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: BLOOD LINE                              *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY BLOOD LINE         *
      *                                                             *
      * COINSURANCE RECORD COMBINATIONS:                            *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       BLOOD ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT   *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO BLOOD ADMINISTERED ON THE   *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH BLOOD ADMINISTERED ON THE      *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = R =>               *
      *       BLOOD ADMINSTERED ON THE DATE OF SERVICE              *
      *                                                             *
      ***************************************************************
       16450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                PERFORM 16455-SEARCH-KEY
                   THRU 16455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = R LINES (BLOOD)                                *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET BLOOD-FLAG TO INDICATE BLOOD LINE                       *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO BLOOD-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                   PERFORM 16455-SEARCH-KEY
                      THRU 16455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY BLOOD LINE)*
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = R       *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW BLOOD COINSURANCE ENTRY             *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 16475-STAGE-DCP-ENTRY
                      THRU 16475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, BLOOD                                        *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       16450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COINSURANCE CAP ROLL-UP TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       16455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH COINSURANCE CAP TABLE STARTING AT ENTRY #1           *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 16460-ADD-ENTRY
                      THRU 16460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 16465-UPDATE-ENTRY
                      THRU 16465-UPDATE-ENTRY-EXIT.

       16455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE COINSURANCE TABLE                                       *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       16460-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COINSURANCE CAP TABLE ENTRY         *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 16475-STAGE-DCP-ENTRY
                THRU 16475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, BLOOD                                        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       16460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COINSURANCE RECORD WITH THE SAME        *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       16465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR BLOOD LINES - ACCUMULATE DAY'S TOTAL BLOOD COIN DUE     *
      * -REMOVE ' G' & ' K'                                         *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A BLOOD LINE, UPDATE THE RECORD   *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 16485-REPLACE-TYPE1
                     THRU 16485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 16480-RANK-COIN
                     THRU 16480-RANK-COIN-EXIT.

       16465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COINSURANCE RECORD WITH A HIGHER          *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       16475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       16475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST WAGE ADJ.  *
      * NATIONAL COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE  *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       16480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       16480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = R        *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = BLOOD LINE NEW COINSURANCE AMOUNT(S)              *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       16485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       16485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 15600-ADJ-CHRG-OUTL.)                     *
      *                                                             *
      ***************************************************************
       16500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
      * 12/18/2009 - ADD SIS R & U, WHICH ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P' OR ' R' OR ' U' OR 'J1' OR 'J2')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                AND NOT PKG-BLD-DED-LINE
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       16500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    & TAKE PT DEVICE OFFSET WHEN APPLICABLE                  *
      * 5. CALCULATE AND APPLY DEVICE CREDIT                        *
      *                                                             *
      ***************************************************************
       16550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 16655-SET-BD-HCPCS-FLAG
                THRU 16655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      *   FLAG LINE IF ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND CLAIM  *
      *   HAS A COMPREHENSIVE APC; TREAT AS PACKAGED LINE           *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             ELSE
                  MOVE 'N' TO PKG-BLD-DED-LINE-FLAG
             END-IF.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).


      ***************************************************************
      * CALCULATE DEVICE CREDIT FOR ELIGIBLE LINE(S)                *
      *-------------------------------------------------------------*
      * 02/09/2016- REVISED LOGIC IMPLEMENTED IN APRIL 2016         *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-CLAIM-DEVCR-AMT > 0 AND
                H-TOT-DEVCR-PYMTS > 0
                PERFORM 16550-DEVICE-CREDIT
                   THRU 16550-DEVICE-CREDIT-EXIT.


      ***************************************************************
      * CALCULATE DEVICE OFFSET FOR ELIGIBLE TERMINATED PROCEDURE   *
      * LINES AND REDUCE THE APC PAYMENT BY THE DEVICE OFFSET AMOUNT*
      *-------------------------------------------------------------*
      * 02/09/2016- NEW LOGIC IMPLEMENTED IN APRIL 2016             *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16' AND
                L-PAYER-ONLY-VC-QQ > 0 AND
                H-TOT-TPDO-PYMTS > 0
                PERFORM 16550-TERM-PROC-DEV-OFF
                   THRU 16550-TERM-PROC-DEV-OFF-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, X, J1, OR J2 LINES   *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      * 10/26/2016 - STOPPED PERFORMING PHP OUTLIER CAPPING LOGIC   *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X' OR
                 'J1' OR 'J2') THEN
                  PERFORM 16550-SCH-ADJ
                     THRU 16550-SCH-ADJ-EXIT
                  PERFORM 16560-CALC-BENE-DEDUCT
                     THRU 16560-CALC-BENE-DEDUCT-EXIT


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (PT DEVICE) LINES, PAYMENT IND.*
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      *-------------------------------------------------------------*
      * 01/01/2009 - BRACHYTHERAPY SERVICES ADDED FOR CY 2009       *
      * 11/15/2009 - BRACHYTHERAPY SERVICES (SI=U) REMOVED CY 2010  *
      *            - THERAPEUTIC RADIOPHARMS' SI NOT 'H' FOR CY2010 *
      * 08/11/2010 - NEW PASS-THROUGH DEVICE OFFSET LOGIC ADDED IN  *
      *              PARAGRAPH 10555-CALC-H-STANDARD                *
      * 11/16/2015 - REVISED PT-DEVICE LOGIC: 15555-CALC-H-STANDARD *
      ***************************************************************
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' H') THEN
                 IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                       OPPS-PYMT-IND (LN-SUB) = ' 6')
                   PERFORM 16555-CALC-H-STANDARD
                      THRU 16555-CALC-H-STANDARD-EXIT
                   PERFORM 16560-CALC-BENE-DEDUCT
                      THRU 16560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 16550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = R & U LINES; THE PMT. IND.       *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      * 11/15/2009 - ADDED BRACHYTHERAPY SERVICES (SI=U) FOR CY2010 *
      *              THERAPEUTIC RADIOPHARMS' SI=K FOR CY 2010      *
      * 11/16/2009 - ADD LOGIC TO ADJUST PT CONTRAST AGENT HCPCS    *
      *              LINE PAYMENT BY OFFSET                         *
      * 05/10/2016 - CALCULATE BLOOD DEDUCTIBLE & LINE PAYMENT FOR  *
      *              BLOOD DEDUCTIBLE LINES ON COMPREHEMSIVE APC    *
      *              CLAIMS (THESE LINES WERE PREVIOUSLY PACKAGED)  *
      *            - ADD LOGIC TO EXEMPT BLOOD DEDUCTIBLE LINES ON  *
      *              COMPREHENSIVE APC CLAIMS FROM REIM, COIN, &    *
      *              NON-BLOOD DEDUCTIBLE CALCS.                    *
      * 10/21/2016 - NO LONGER CALCULATE PAYMENT FOR SI G & K LINES *
      *              (DRUGS) IN PRICER; NOW CALCULATED IN FISS      *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 16550-CALC-RU
                         THRU 16550-CALC-RU-EXIT

                      IF PKG-BLD-DED-LINE
                         NEXT SENTENCE
                      END-IF

                      PERFORM 16560-CALC-BENE-DEDUCT
                         THRU 16560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 16550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      * 11/12/2008 - BRACHYTHERAPY SOURCE'S STATUS INDICATOR = ' U' *
      *              EFFECTIVE 1/1/2009                             *
      *                                                             *
      * 11/16/2009 - REMOVED LOGIC FOR THERAPEUTIC RADIOPHARMS &    *
      *              BRACHYTHERAPY SOURCES B/C THESE ARE NOT PAID   *
      *              AT COST FOR CY 2010                            *
      *                                                             *
      * 04/11/2011 - ADDED LOGIC TO PREVENT LINES WITH PAFS 9 OR 10 *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      * 05/13/2016 - ADDED LOGIC FOR BLOOD DEDUCTIBLE LINES ON A    *
      *              COMPREHENSIVE APC CLAIM (ZERO OUT REIM, COIN,  *
      *              & NON-BLOOD DEDUCTIBLE)                        *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * FOR BLOOD DEDUCTIBLE LINES ON A COMPREHENSIVE APC CLAIM:    *
      * SET REIMBURSEMENT, COINSURANCE, & DEDUCTIBLE AMOUNTS TO $0  *
      *-------------------------------------------------------------*
             IF PKG-BLD-DED-LINE
                MOVE 0 TO H-LITEM-REIM
                          H-TOTAL-LN-DEDUCT
                          H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 16550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE REIMBURSEMENT AND SET COINSURANCE AMOUNTS TO $0   *
      * FOR LINES WITH A PAF= 9 OR 10  OR 23                        *
      * 01/14/2019 ADDED PAF = 23                                   *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 9' OR '10' OR '23')
                COMPUTE H-LITEM-REIM ROUNDED =
                   H-LITEM-PYMT - H-TOTAL-LN-DEDUCT
                MOVE 0 TO H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 16550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                  H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX).



      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * FOR SECTION 603 SERVICES -                                  *
      * SET MIN, MAX, AND REDUCED COINSURANCE TO PSF STANDARD       *
      * FOR LINES WITH A PMF= 7 OR 8                                *
      *-------------------------------------------------------------*
             IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                COMPUTE H-MIN-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                COMPUTE H-MAX-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                MOVE 0  TO H-RED-COIN

                GO TO 16550-CALC-STANDARD-EXIT
             END-IF.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DEVICES, BRACHYTHERAPY, & BLOOD                             *
      * (SI = H LINES HAVE A MIN-COIN = 0, WON'T ENTER LOGIC)       *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) =
                  ' H' OR ' R' OR ' U'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       16550-CALC-STANDARD-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE LINE'S DEVICE CREDIT AMOUNT                   *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - REVISED LOGIC IMPLEMENTED APRIL 2016           *
      *                                                             *
      ***************************************************************
       16550-DEVICE-CREDIT.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE CREDIT     *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-DEVCR-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-DEVCR-PYMTS.

           COMPUTE H-LINE-DEVCR-AMT ROUNDED =
                   H-CLAIM-DEVCR-AMT * H-LINE-DEVCR-PYMT-RATE.

       16550-DEVICE-CREDIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE TERMINATED PROCEDURE LINE'S DEVICE OFFSET     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - NEW FOR CY 2016 (APRIL IMPLEMENTATION)         *
      *                                                             *
      ***************************************************************
       16550-TERM-PROC-DEV-OFF.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE OFFSET     *
      * FOR TERMINATED PROCEDURES                                   *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-TPDO-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-TPDO-PYMTS.

           COMPUTE H-LINE-TPDO-AMT ROUNDED =
                   L-PAYER-ONLY-VC-QQ * H-LINE-TPDO-PYMT-RATE.

      *-------------------------------------------------------------*
      * ADJUST THE BASE APC PAYMENT BY THE DEVICE OFFSET            *
      *-------------------------------------------------------------*
           IF W-APC-PYMT (W-LP-INDX) >= H-LINE-TPDO-AMT
              COMPUTE W-APC-PYMT (W-LP-INDX) ROUNDED =
                      W-APC-PYMT (W-LP-INDX) - H-LINE-TPDO-AMT
           ELSE
              MOVE 0 TO W-APC-PYMT (W-LP-INDX)
           END-IF.

       16550-TERM-PROC-DEV-OFF-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *        FOR LINES WITH A SI OF S, V, T, P, X, R, OR U        *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA MUST BE A  *
      *   VALUE OF '   01' THRU '   99' AND THE L-PSF-PROV-TYPE     *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2017: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      * 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES (SI=R)     *
      *              ADDED TO LOGIC.  BRACHY LINES NOT PROCESSED IN *
      *              PARAGRAPH & NOW HAVE A SI = U, SI = K LOGIC    *
      *              REMOVED FROM THIS PARAGRAPH.                   *
      * 05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD    *
      *              DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.     *
      *              FIX EFFECTIVE RETROACTIVE TO 01/01/2009.       *
      * 11/17/2009 - BRACHYTHERAPY LINES NOW PROCESSED IN THIS      *
      *              PARAGRAPH FOR CY 2010 (SI=U), DO NOT RECEIVE   *
      *              WAGE ADJUSTMENT                                *
      * 05/09/2011 - REVISED LOGIC TO EXCLUDE BILL TYPE 14X FROM    *
      *              RECEIVING THE SCH ADD-ON                       *
      * 02/07/2012 - REPLACE BILL14X-FLAG WITH CONDITION NAME       *
      *              BILL-TYPE-14X                                  *
      * 01/27/2014 - WHEN APPLICABLE, SUBTRACT DEVICE CREDIT        *
      *              AMOUNT FROM LINE ITEM PAYMENT                  *
      * 10/21/2016 - EXCLUDE SECTION 603 SERVICE LINES FROM SCH ADJ *
      *                                                             *
      ***************************************************************
       16550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      *   - SECTION 603 SERVICES EXCLUDED FROM THE SCH ADJUSTMENT   *
      ***************************************************************

             IF (RURAL-GEO OR RURAL-WI) AND
                (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22') AND
                (NOT BILL-TYPE-14X) AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7') AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8')

      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      ***************************************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = R (BLOOD) OR U (BRACHY) LINES ARE NOT WAGE-ADJUSTED    *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U'
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.

      *-------------------------------------------------------------*
      * REDUCE ADJUSTED APC PAYMENT BY DEVICE CREDIT IF APPLICABLE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-LINE-DEVCR-AMT > 0
                IF H-LITEM-PYMT >= H-LINE-DEVCR-AMT
                   COMPUTE H-LITEM-PYMT ROUNDED =
                           H-LITEM-PYMT - H-LINE-DEVCR-AMT
                ELSE
                   MOVE 0 TO H-LITEM-PYMT
                END-IF
             END-IF.


       16550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = R & U LINES:         *
      *   - APC PAYMENT FOR BLOOD LINES (SI = R)                    *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = U LINES                      *
      *   - SCH ADJUSTMENT APPLIED TO BLOOD & BRACHY LINES          *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      * - 11/12/2008 - FOR CY 2009, BRACHYS NOT PROCESSED IN THIS   *
      *   PARAGRAPH; BRACHY LINES ASSIGNED A NEW SI OF ' U'         *
      * - 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES HAVE A   *
      *   SI = R                                                    *
      * - 12/05/2008 - MODIFIED LOGIC TO SEND BLOOD LINES WITHOUT   *
      *   A PMT ADJ FLAG = 5 OR 6 TO THE SCH ADJUSTMENT PARAGRAPH,  *
      *   INCLUDED SI = R IN THE BLOOD IDENTIFICATION LOGIC         *
      * - 11/15/2009 - BRACHYTHERPY SERVICES (SI = U) & THERAPEUTIC *
      *   RADIOPHARMS (SI = K) SENT TO THIS PARAGRAPH FOR CY 2010,  *
      *   LOGIC ALTERED TO PROCESS SI = U (RECEIVE REGULAR APC PMT) *
      * - 11/17/2009 - SEND BRACHYTHERAPY LINES TO 10550-SCH-ADJ TO *
      *   MAKE ELIGIBLE FOR SCH ADJUSTMENT, NOT WAGE ADJUSTED       *
      * - 05/10/2016 - ADDED LOGIC FOR SPECIAL HANDLING OF BLOOD    *
      *   DEDUCTIBLE LINES ON CLAIMS WITH A COMPREHENSIVE APC       *
      * - 11/2016 - REMOVED LOGIC FOR SI = G & K LINES (DRUGS)      *
      *                                                             *
      ***************************************************************
       16550-CALC-RU.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 16550-SET-BLOOD-FRACTION
                     THRU 16550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 16550-ADJ-BLOOD-COST
                     THRU 16550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 16550-SCH-ADJ
                     THRU 16550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * CHANGE THE PAYMENT OF THE BLOOD DEDUCTIBLE LINE ON THE SAME *
      * CLAIM AS A COMPREHENSIVE APC TO THE BLOOD DEDUCTIBLE AMOUNT *
      *-------------------------------------------------------------*
                  IF PKG-BLD-DED-LINE
                      MOVE H-LN-BLOOD-DEDUCT TO H-LITEM-PYMT
                  END-IF

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE, BUT PAF = 5 OR 6           *
      * (BLOOD PROCESSING AND PRODUCT BILLED TOGETHER)              *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 16550-ADJ-PLATE-COST
                      THRU 16550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 16550-SCH-ADJ
                      THRU 16550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE AND PAF NOT EQUAL TO 5 OR 6 *
      * (ONLY BLOOD PRODUCT BILLED)                                 *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 12/05/2008 - 7550-SCH-ADJ PERFORM ADDED FOR BLOOD LINES     *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 16550-SCH-ADJ
                      THRU 16550-SCH-ADJ-EXIT
                ELSE
                   IF OPPS-SRVC-IND (LN-SUB) = ' U'
                      PERFORM 16550-SCH-ADJ
                         THRU 16550-SCH-ADJ-EXIT
                   END-IF
                END-IF
             END-IF
             END-IF.

       16550-CALC-RU-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       16550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       16550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       16550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       16550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       16550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       16550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *           CALCULATE PAYMENT FOR PAID AT COST LINES          *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 08-11-2010 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED       *
      * 11-17-2015 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED AGAIN *
      * 08-18-2016 - USE DEVICE CCR WHEN AVAILABLE                  *
      *                                                             *
      ***************************************************************
       16555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST - "PAID AT COST"         *
      * (IF NO DEVICE CCR USE HOSPITAL CCR)                         *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

              IF L-PSF-DEVICE-CCR = 0
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG *  L-PSF-OPCOST-RATIO)
              ELSE
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG * L-PSF-DEVICE-CCR)
              END-IF.

      *-------------------------------------------------------------*
      * FOR PASS-THROUGH DEVICE LINE WITH AN ASSOCIATED OFFSET,     *
      * APPLY THE OFFSET (INDICATED BY PAF = '12' OR '13' OR '15'   *
      * (NOT CURRENTLY USING PAF '15')                              *
      *-------------------------------------------------------------*
              IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12' OR
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13' OR
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
                 PERFORM 16556-CALC-PTD-OFFSET
                    THRU 16556-CALC-PTD-OFFSET-EXIT
              END-IF.

      *-------------------------------------------------------------*
      * CAPTURE PAYMENT AMOUNT                                      *
      *-------------------------------------------------------------*
             IF T-LITEM-PYMT < 0 THEN
                MOVE 0 TO H-LITEM-PYMT
             ELSE
                MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

       16555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *   REDUCE LINE ITEM PAYMENTS OF PASS-THROUGH DEVICES THAT    *
      * HAVE AN ASSOCIATED PROCEDURE ON THE CLAIM BY THE PROCEDURE  *
      *                WAGE-ADJUSTED OFFSET AMOUNT                  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ** EFFECTIVE 11/13/2015 - REVISED PT DEVICE OFFSET LOGIC    *
      *                                                             *
      ***************************************************************
       16556-CALC-PTD-OFFSET.

      *-------------------------------------------------------------*
      * DETERMINE WHICH VARIABLES TO USE IN CALCULATIONS            *
      *-------------------------------------------------------------*
            INITIALIZE H-TOT-PTD-CHARGES
                       H-WA-PTD-OFFSET.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
               MOVE H-QN-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QN-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
               MOVE H-QO-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QO-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *     IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *        MOVE H-QP-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
      *        MOVE H-QP-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
      *     END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHAT % OF THE OFFSET WILL BE APPLIED              *
      *-------------------------------------------------------------*
            IF H-TOT-PTD-CHARGES > 0
               COMPUTE W-PTDO-CHRG-RATE ROUNDED =
                       H-SUB-CHRG / H-TOT-PTD-CHARGES
            ELSE
               GO TO 16556-CALC-PTD-OFFSET-EXIT
            END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE TAKEN                     *
      *-------------------------------------------------------------*
            COMPUTE W-PTDO-LINE-OFFSET ROUNDED =
                    W-PTDO-CHRG-RATE *
                    H-WA-PTD-OFFSET.

      *-------------------------------------------------------------*
      * SUBTRACT THE OFFSET AMOUNT FROM THE LINE PAYMENT            *
      *-------------------------------------------------------------*
            IF W-PTDO-LINE-OFFSET <= T-LITEM-PYMT
               COMPUTE T-LITEM-PYMT ROUNDED =
                       T-LITEM-PYMT - W-PTDO-LINE-OFFSET
            ELSE
               MOVE 0 TO T-LITEM-PYMT
            END-IF.


       16556-CALC-PTD-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       16560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * LINES INELIGIBLE FOR DEDUCTIBLE SKIP DEDUCTIBLE CALCULATION *
      * EFF. 7/1/2009 - CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      * ASSIGNED A PAF = ' 4'                                       *
      * - 04/11/2011 - ADDED PAF 9 FOR SERVICES WHERE THE           *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *   (ADDED FOR PREVENTIVE SERVICES WAIVER IN CY 2011)         *
      * - 01/15/2019 - ADDED PAF 23                                 *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 4' OR ' 9' OR '23')
                GO TO 16560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       16560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      * - 11/12/2008: FOR CY 2009, BRACHYS SI = U AND BLOOD SI = R  *
      *   BRACHY INELIGIBLE FOR OUTLIER, BLOOD ELIGIBLE FOR OUTLIER *
      *                                                             *
      * - 12/05/2008: ADDED SI = K TO LIST OF SIS INELIGIBLE FOR    *
      *   OUTLIER (BRACHYS & BLOOD NO LONGER HAVE SI = K)           *
      *                                                             *
      * - 11/17/2009: REMOVED U FROM LIST OF SIS INELIGIBLE FOR     *
      *   OUTLIER; BRACHYS NOW ELIGIBLE B/C NOT PAID AT COST CY 2010*
      *                                                             *
      * - 12/16/2009: ADDED SIS R AND U TO LOGIC THAT DISTRIBUTES   *
      *   PACKAGED CHARGES TO PAYABLE LINES. V2010.1.2              *
      *                                                             *
      * - 11/04/2011: MODIFIED LOGIC TO APPLY THE PHP CAP ONLY TO   *
      *   PHP CMHC LINES, NOT PHP HOSPITAL LINES PER POLICY'S       *
      *   INSTRUCTIONS                                              *
      *                                                             *
      * - 11/17/2015: MODIFIED LOGIC TO STOP ACCOUNTING FOR         *
      *   PASS-THROUGH DEVICE PAYMENTS AND CHARGES IN ASSOCIATED    *
      *   PROCEDURE'S OUTLIER CALCULATION.  ADDED STATUS INDICATOR  *
      *   'J2' AS ELIGIBLE FOR OUTLIER AND TO RECEIVED PACKAGED     *
      *   CHARGES                                                   *
      *                                                             *
      * - 05/10/2016: ADDED LOGIC TO EXCLUDE LINES ELIGIBLE FOR THE *
      *   BLOOD DEDUCTIBLE AND ON A CLAIM WITH A COMPREHENSIVE APC  *
      *   FROM THE OUTLIER PAYMENT                                  *
      *                                                             *
      * - 10/21/2016: ADDED LOGIC TO EXCLUDE SECTION 603 SERVICE    *
      *   LINES FROM THE OUTLIER PAYMENT (PMF = 7 OR 8)             *
      *                                                             *
      ***************************************************************
       16600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * SERVICE LINES NOT ELIGIBLE FOR AN OUTLIER PAYMENT:          *
      *   DEVICES, PACKAGED, PACKAGED AS PART OF DRUG ADMIN, AND    *
      *   SECTION 603 SERVICES                                      *
      *-------------------------------------------------------------*
      * 11/12/2008 - BRACHY (SI=U) ADDED TO LIST                    *
      * 12/05/2008 - SI K ADDED TO THE LIST                         *
      * 11/16/2009 - REMOVED PAF=2 FROM BRACHY (SI=U) CRITERIA      *
      * 11/17/2009 - REMOVE SI=U, BRACHYS ARE ELIGIBLE FOR OUTLIER  *
      * 07/26/2016 - REMOVE SI=G SI=K                               *
      * 10/21/2016 - SECTION ADDED 603 SERVICES (PMF = 7 OR 8)      *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' H' OR ' N') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8')
                   GO TO 16600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * BLOOD LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND ON A      *
      * CLAIM WITH A COMPREHENSIVE APC NOT ELIGIBLE FOR OUTLIER     *
      *-------------------------------------------------------------*
      * 05/10/2016 - NEW FOR JULY 2016                              *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  GO TO 16600-ADJ-CHRG-OUTL-EXIT
             END-IF.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                           ' X' OR ' P' OR ' R' OR
                                           ' U' OR 'J1' OR 'J2') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                          ' X' OR ' P' OR ' R' OR
                                          ' U' OR 'J1' OR 'J2') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A COMPOSITE ADJ.     *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 01 - NN...) ARE ACCUMULATED BY COMPOSITE            *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME        *
      * (PAYABLE) LINE'S CHARGES.                                   *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2007 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      * 11/12/2008 - CHANGED LOGIC TO USE THE COMPOSITE ADJUSTMENT  *
      *              FLAG INSTEAD OF THE PAYMENT ADJUSTMENT FLAG    *
      *              VALUES 91 - 99 TO ID PRIME COMPOSITE LINES     *
      ***************************************************************

      *-------------------------------------------------------------*
      * COMPOSITE ADJUSTMENT FLAG > 0 INDICATES COMPOSITE APC       *
      *-------------------------------------------------------------*
           IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = '00'

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.


      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD                          *
      *   (ALWAYS USE THE PHP "CAP" APC'S WAGE ADJ PMT FOR PHP LINES*
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED BECAUSE PAYMENTS MAY BE ADJUSTED FOR     *
      *              PASS-THROUGH DEVICES                           *
      * ??/??/2008 - NEW FOR CY 2009 - ALWAYS USE THE PHP "CAP"     *
      *              APC'S WAGE ADJ "CAP" PMT FOR PHP LINES (SI=P)  *
      * 11/04/2011 - ONLY APPLY PHP "CAP" TO CMHC LINES; PER        *
      *              POLICY'S INSTRUCTIONS PHP HOSPITAL LINES ARE   *
      *              NOT CAPPED.                                    *
      * 11/17/2015 - CONTINUE TO USE THIS LOGIC EVEN THOUGH PAYMENTS*
      *              ARE NO LONGER ADJUSTED FOR PT DEVICES          *
      * 10/26/2016 - DISABLED CMHC PHP PMT CAP BECAUSE ALL PHP CMHCS*
      *              USE THE SAME APC EFFECTIVE JANUARY 2017        *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL.


      ***************************************************************
      *                                                             *
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      * -NEW FOR JANUARY 2009                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE PHP "CAP" APC'S LINE PAYMENT                        *
      *                                                             *
      * -NEW FOR JANUARY 2017                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE SAME PHP APC (NO NEED TO CAP PMT)                   *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      * (CMHC PROVIDERS ONLY PROCESS PARTIAL HOSPITALIZATION LINES) *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT

      ***************************************************************
      *     ADD LOGIC TO PREVENT NEGATIVE OUTLIER PAYMENT           *
      ***************************************************************
                   IF H-LITEM-OUTL-PYMT < 0
                      MOVE 0 TO H-LITEM-OUTL-PYMT
                   END-IF


      *-------------------------------------------------------------*
      *     FOR CMHC PROVIDERS THAT ARE SUBJECT TO THE OUTLIER CAP, *
      *     ACCUMULATE CLAIM PAYMENT AND OUTLIER TOTALS             *
      *-------------------------------------------------------------*
                   IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '0'
                        COMPUTE H-CMHC-PYMT-TOTAL =
                          H-CMHC-PYMT-TOTAL + H-LITEM-PYMT-OUTL

                        COMPUTE H-CMHC-OUTL-TOTAL =
                          H-CMHC-OUTL-TOTAL + H-LITEM-OUTL-PYMT
                   END-IF

      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE

                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 3825)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT
                  END-IF
               END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT.


      *-------------------------------------------------------------*
      * LINES THAT ARE NOT ELIGIBLE FOR AN OUTLIER PAYMENT BECAUSE  *
      * OUTLIER CAP WAS MET BEFORE THIS CLAIM WAS PROCESSED -       *
      * ZERO OUT LINE OUTLIER PAYMENT & REMOVE FROM CLAIM TOTAL     *
      * 8/21/16 -MOVE 2 TO RETURN CODE, IF FLAG = 6 & OUTL PYMT > 0 *
      *-------------------------------------------------------------*
             IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6')
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT
                MOVE 02 TO A-CLM-RTN-CODE.


       16600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *               CAP CMHC TOTAL OUTLIER PAYMENTS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      * FOR CMHC CLAIMS ONLY, DO THE FOLLOWING:                     *
      *                                                             *
      * - DETERMINE IF THE TOTAL CLAIM OUTLIER PAYMENT ELIGIBLE     *
      *   FOR CAPPING IS > $0                                       *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS PAYMENTS INCLUDING THE *
      *   CURRENT CLAIM'S PAYMENTS                                  *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS OUTLIER PAYMENTS       *
      *   INCLUDING THE CURRENT CLAIM'S OUTLIER PAYMENTS            *
      * - CALCULATE THE CURRENT OUTLIER PERCET                      *
      * - IF THE OUTLIER PERCENT EXCEEDS THE CAP:                   *
      *   - SET THE CLAIM OUTLIER TO $0                             *
      *   - SET THE RETURN CODE TO 02                               *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JULY 2017, EFFECTIVE JANUARY 2017                 *
      *                                                             *
      ***************************************************************
       16610-CMHC-OUTL-CAP.
             IF ( (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999') ) AND
                H-CMHC-OUTL-TOTAL > 0

      *-------------------------------------------------------------*
      *            CALCULATE PROVIDER'S TOTAL PAYMENTS              *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-PYMT-TOTAL =  H-CMHC-PYMT-TOTAL +
                        L-PRIOR-PYMT-TOTAL

      *-------------------------------------------------------------*
      *       CALCULATE PROVIDER'S TOTAL OUTLIER PAYMENTS           *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTL-TOTAL =  H-CMHC-OUTL-TOTAL +
                        L-PRIOR-OUTL-TOTAL

      *-------------------------------------------------------------*
      *                 CALCULATE OUTLIER PERCENT                   *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTLIER-PCT ROUNDED =
                   H-CMHC-OUTL-TOTAL / H-CMHC-PYMT-TOTAL

      *-------------------------------------------------------------*
      *                     APPLY OUTLIER CAP                       *
      *-------------------------------------------------------------*
                IF H-CMHC-OUTLIER-PCT > CMHC-OUTL-CAP-PCT
                   MOVE 0 TO H-OUTLIER-PYMT
                   MOVE 02 TO A-CLM-RTN-CODE
                END-IF
             END-IF.

       16610-CMHC-OUTL-CAP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 16550-CALC-RU &        *
      *      16550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES        *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       16655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9056' OR
                                    'P9021' OR
                                    'P9010' OR
                                    'P9016' OR
                                    'P9051' OR
                                    'P9057' OR
                                    'P9038' OR
                                    'P9058' OR
                                    'P9040' OR
                                    'P9054' OR
                                    'P9022' OR
                                    'P9039'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       16655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *        PROCESS COINSURANCE CAP ROLL-UP TABLE RECORDS        *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE BLOOD LINE COINSURANCE WHEN THE PROCEDURE       *
      *  COINSURANCE AMOUNTS PLUS THE BLOOD COINSURANCE AMOUNT(S)   *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       16800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 16810-PROCESS-TYPE1
                   THRU 16810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 16840-PROCESS-TYPE2
                   THRU 16840-PROCESS-TYPE2-EXIT.

       16800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH BLOOD COINSURANCE, DETERMINE THE  *
      *  % OF TOTAL BLOOD COINSURANCE THAT CAN BE PAID IN ADDITION  *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE BLOOD COINSURANCE CAN BE PAID*
      *  WHEN H-RATIO = 1, ALL OF THE BLOOD COINSURANCE CAN BE PAID *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       16810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * BLOOD WAS ADMINISTERED ON THE DAY                           *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & WAGE ADJUSTED COINSURANCE OF THE      *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL BLOOD COIN THAT CAN BE   *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S BLOOD COIN CAN BE PAID B/C THE PROCEDURE/ *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL BLOOD COINSURANCE CAN BE PAID WITHIN THE    *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       16810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE BLOOD LINE'S NATIONAL COINSURANCE AMOUNT AND    *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       16840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 BLOOD COIN REC HAS SAME DATE OF SERVICE AS   *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE BLOOD COIN RECORD*
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE BLOOD LINE BY  *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD BLOOD COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT   *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       16840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       16900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       16900-END-PRICE-RTN-EXIT.
           EXIT.





      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 17000 FOR CALENDAR YEAR 2018 PROCESSING        **
      **          SERVICE FROM DATES: 1/1/2018 - 12/31/2018           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE IOCE)      *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  7. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  8. CALCULATE SERVICE LINE PAYMENTS                            *
      *  9. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 10. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 11. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 12. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 13. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, AND COMPOSITE *
      *     CHARGES OF APPLICABLE PROCEDURES.                          *
      *     ALL ADJUSTMENTS ARE DONE FOR OUTLIER DETERMINATION ONLY.   *
      * 14. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 15. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR BLOOD LINES; *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE BLOOD LINE'S REIMBURSEMENT                    *
      * 17. ACCUMULATE CLAIM TOTALS                                    *
      * 18. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       17000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY),  *
      *            DETERMINE CLAIM DEVICE CREDIT AMOUNT               *
      *            (CLAIM LEVEL INITIALIZATION)                       *
      *                                                               *
      *****************************************************************
              PERFORM 17100-INIT
                 THRU 17100-INIT-EXIT.

      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - C-APC-CLAIM-FLAG - COMPREHENSIVE APC ON CLAIM - FOR       *
      *     SPECIAL BLOOD DEDUCTIBLE LINE LOGIC                       *
      *                                                               *
      *****************************************************************
              PERFORM 17125-INIT
                 THRU 17125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.



      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH *
      *            RADIOPHARMACEUTICAL OFFSET, CREATE CONTRAST        *
      *            AGENT PROCEDURE TABLE FOR PASS-THROUGH CONTRAST    *
      *            AGENT OFFSET.                                      *
      *            (LOOP THROUGH THE CLAIM LINES)                     *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY TABLES FOR NEW CLAIM                             *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX    W-BLD-MAX    W-CMP-MAX.

              PERFORM 17150-INIT
                 THRU 17150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      *-------------------------------------------------------------*
      * CALCULATE WAGE-ADJUSTED PASS-THROUGH DEVICE OFFSETS         *
      * (VALUE CODES QN, QO & QP; CLAIM LEVEL)                      *
      * NEW FOR CY2016 - 11/13/2015                                 *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QN > 0
                COMPUTE H-QN-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QN * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QN * .40)
             END-IF.

             IF L-PAYER-ONLY-VC-QO > 0
                COMPUTE H-QO-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QO * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QO * .40)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF L-PAYER-ONLY-VC-QP > 0
      *         COMPUTE H-QP-WA-PTD-OFFSET ROUNDED =
      *                 ((L-PAYER-ONLY-VC-QP * .60) * H-WINX) +
      *                 (L-PAYER-ONLY-VC-QP * .40)
      *      END-IF.



      *****************************************************************
      *                                                               *
      *   STEP 4 - INITIALIZE W-DCP-MAX                               *
      *   ------                                                      *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, AND MOVE LINE ITEM         *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 17400-CALCULATE
                 THRU 17400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, AND COMPOSITES, AND CALCULATE  *
      *            OUTLIER PAYMENTS                                   *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 17600-ADJ-CHRG-OUTL
                 THRU 17600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.
              PERFORM 17610-CMHC-OUTL-CAP
                 THRU 17610-CMHC-OUTL-CAP-EXIT.

      *****************************************************************
      *                                                               *
      *   STEP 7 - RECALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS*
      *   ------   FOR STATUS INDICATOR R (BLOOD) LINES WHEN THE DAILY*
      *            INPATIENT DEDUCTIBLE CAP IS EXCEEDED.              *
      *            THE COINSURANCE CAP IS APPLIED USING THE WAGE      *
      *            ADJUSTED NATIONAL COINSURANCE OF EACH DAY'S MOST   *
      *            EXPENSIVE PROCEDURE OR VISIT.                      *
      *            (LOOP THROUGH THE COINSURANCE CAP ROLL-UP TABLE)   *
      *                                                               *
      *****************************************************************
                IF BLOOD-FLAG = 'Y'
                   PERFORM 17800-ADJ-STV-REIM
                      THRU 17800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                END-IF.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 17900-END-PRICE-RTN
                 THRU 17900-END-PRICE-RTN-EXIT.

       17000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY DEDUCTIBLE CAP (H-IP-LIMIT)            *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       17100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE FLAGS AND VARIABLES               *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 11/03/2008 - APC33-FLAG REPLACED BY PHP-APC-FLAG            *
      * 11/12/2008 - BRACHY-APC-FLAG REMOVED, NOT USED FOR CY 2009  *
      * 02/09/2009 - PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG ADDED    *
      * 11/16/2009 - RADIOPH-APC-FLAG REMOVED; PTCA-CLAIM-FLAG,     *
      *              PTCA-LINE FLAG ADDED                           *
      * 02/07/2012 - BILL14X-FLAG REMOVED                           *
      * 11/18/2013 - DEVCR-CLAIM-FLAG ADDED                         *
      * 11/17/2015 - REMOVED APC34-FLAG (MENTAL HEALTH), PTD-FLAG,  *
      *              PTD-LINE-FLAG, PTD-PROC-FLAG, AND              *
      *              C1820-OFFSET-FLAG BECAUSE THEY'RE NOT USED     *
      * 02/09/2016 - ADD LOGIC TO DETERMINE CLAIM'S DEVICE CREDIT   *
      * 02/10/2016 - DEVCR-CLAIM-FLAG REMOVED (NO LONGER USED)      *
      * 10/26/2016 - PHP-HCPCS-FLAG, MH-HCPCS-FLAG,                 *
      *              PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG,         *
      *              PTCA-CLAIM-FLAG, PTCA-LINE-FLAG REMOVED        *
      *              (NO LONGER USED)                               *
      *                                                             *
      *-------------------------------------------------------------*
             MOVE 'N'   TO BLOOD-FLAG
                           ST0-FLAG
                           N-FLAG
                           BLD-DEDUC-HCPCS-FLAG
                           C-APC-CLAIM-FLAG
                           PKG-BLD-DED-LINE-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO  TO A-OUTLIER-PYMT
                           A-TOTAL-CLM-DEDUCT
                           A-TOT-CLM-CHRG
                           A-TOT-CLM-PYMT
                           A-BLOOD-DEDUCT-DUE
                           A-BLOOD-PINTS-USED
                           A-WINX
                           W-LNC-MAX
                           A-DEVICE-CREDIT-QD.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
      *-------------------------------------------------------------*
      * INITIATILIZE WORKING STORAGE DATES - 10-23-2014             *
      *-------------------------------------------------------------*
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-BEGIN-YYYY.
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-END-YYYY.

      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 17100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 17100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 17100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION17 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE THE TOTAL DEVICE CREDIT AMOUNT TO BE DEDUCTED     *
      * FROM THE CLAIM - USE THE LESSER OF THE AMOUNT IN            *
      * VALUE CODE FD AND THE CAP AMOUNT IN VALUE CODE QU           *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QU > 0 AND
                L-DEVICE-CREDIT > 0
                IF L-PAYER-ONLY-VC-QU < L-DEVICE-CREDIT
                   MOVE L-PAYER-ONLY-VC-QU TO H-CLAIM-DEVCR-AMT
                ELSE
                   MOVE L-DEVICE-CREDIT TO H-CLAIM-DEVCR-AMT
                END-IF
             END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = 'D'
                      MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
                   ELSE
      *-------------------------------------------------------------*
      *   USE SPECIAL WAGE INDEX WHEN INDICATED                     *
      *   (PSF RECORD EFFECTIVE DATE MUST BE WITHIN THE CLAIM'S CY) *
      *   ADDED 10-23-2014 FOR CY 2015                              *
      *-------------------------------------------------------------*
                      IF (L-PSF-SPEC-PYMT-IND = '1' OR '2') AND
                         (L-PSF-EFFDT >= W-CY-BEGIN-DATE AND
                          L-PSF-EFFDT <= W-CY-END-DATE)
                          MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                          MOVE L-PSF-SPEC-WGIDX TO H-WINX
                          MOVE 1340 TO H-IP-LIMIT
                          GO TO 17100-INIT-EXIT
                      ELSE
                         MOVE  52  TO A-CLM-RTN-CODE
                         GO TO 17100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 17100-INIT-EXIT.

             MOVE 1340 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      * APPLY WAGE INDEX FLOOR POLICY                               *
      * (USE HIGHER OF CBSA WAGE INDEX AND STATE RURAL WAGE INDEX)  *
      *-------------------------------------------------------------*
      * 10-23-2014 - NEW FLOOR LOGIC FOR CY 2015                    *
      * 10-28-2015 - NEW STATE CODES ADDED FOR APRIL 2016           *
      *-------------------------------------------------------------*

      *-------------------------------------------------------------*
      * >FIRST, CONFIRM FLOOR SWITCH IS SET                         *
      *-------------------------------------------------------------*
             SET W-FLOOR-LOOKUP TO TRUE.

      *-------------------------------------------------------------*
      * >GET PROVIDER'S STATE CODE FOR RURAL FLOOR WAGE INDEX       *
      *  LOOK-UP (NEW FOR JULY 2016)                                *
      *-------------------------------------------------------------*
             MOVE L-PSF-STATE-CODE TO W-PSF-PROV-ST.

      *-------------------------------------------------------------*
      * >NOW, CALL WAGE INDEX LOOKUP AND LOOK FOR THE STATE FLOOR.  *
      *  STORE PSF-CBSA IN A-CBSA (IT GETS MOVED THERE IN THE NEXT  *
      *  STEP ANYWAY). THIS FREES H-PSF-CSBA FOR THE FLOOR SEARCH   *
      *  MOVE THREE SPACES + STATE CODE TO H-PSF-CBSA               *
      *  STORE RESULT IN H-WINX.                                    *
      *  MOVE A-CBSA BACK TO H-PSF-CBSA FOR CLEANUP                 *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             STRING '   ' DELIMITED BY SIZE
                   W-PSF-PROV-ST DELIMITED BY SIZE
                   INTO H-PSF-CBSA.
             PERFORM 17200-CALC-WAGEINDX
                THRU 17200-CALC-WAGEINDX-EXIT.
             MOVE A-CBSA TO H-PSF-CBSA.

      *-------------------------------------------------------------*
      * >GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN   *
      *  BY THE PSF SPECIAL WAGE INDEX VALUE)                       *
      *                                                             *
      *   NOTE: IF PSF SPECIAL WAGE INDEX VALUE USED,               *
      *         15100-INIT-EXIT WILL BE CALLED ABOVE - THIS CODE    *
      *         WILL NEVER BE REACHED. THEREFORE CHECKING FOR A 0   *
      *         VALUE SHOULD BE UNNECESSARY.                        *
      * >SET WAGE INDEX LOOKUP FLAG (FLOOR FLAG = 'N')              *
      *-------------------------------------------------------------*
             SET W-WINX-LOOKUP TO TRUE.

                PERFORM 17200-CALC-WAGEINDX
                   THRU 17200-CALC-WAGEINDX-EXIT.

      ***************************************************************
      * DETERMINE OUTMIGRATION ADJUSTMENT BASED ON COUNTY CODE, IF  *
      * WAGE INDEX CBSA FIELD AND STANDARDIZED AMOUNT CBSA FIELD    *
      * BLANK, AND SPECIAL PYMT INDICATOR ARE BLANK APPLY ADJUSTMENT*
      * IF NOT- DONT APPLY                                          *
      ***************************************************************
             IF ( L-PSF-WI-CBSA = '     ' OR
                  L-PSF-WI-CBSA = '00000') AND
                ( L-PSF-PYMT-CBSA = '     ' OR
                  L-PSF-PYMT-CBSA = '00000') AND
                  L-PSF-SPEC-PYMT-IND = ' '

      ***************************************************************
      * INITIALIZE OUTM-IND (INDICATOR) - CLEAR VARIABLE            *
      * SEARCH FOR OUTMIGRATION COUNTY CODE MATCH WITHIN TABLE,     *
      * AT FIRST OCCURENCE USE (OUTM-IDX2) AS POINTER (REFERENCE)   *
      * FOR (OUTM-IDX) INITIAL LINE LOCATION MATCH                  *
      ***************************************************************

                INITIALIZE OUTM-IND
                SET OUTM-IDX TO 1
                SEARCH OUTM-TAB VARYING OUTM-IDX
                   AT END
                      MOVE 0 TO OUTM-IND

                   WHEN OUTM-CNTY(OUTM-IDX) =
                    L-PSF-COUNTY-CODE
                    SET OUTM-IDX2 TO OUTM-IDX
                    MOVE 1 TO OUTM-IND
             END-IF.

      ***************************************************************
      * WHEN OUTM-IND = 1, THIS MEANS COUNTY CODE MATCH WAS FOUND   *
      * LOOP THRU EACH LINE THEN PERFORM PARAGRAPH UNTIL CONDITION  *
      * (IF-STATEMENT) IS TRUE, THE COUNTY CODES NO LONGER MATCH    *
      * ON LAST LINE OF DATE MATCH FOR COUNTY CODE, MOVE            *
      * OUTMIGRATION ADJUSTMENT, TO HLD-OUTM-ADJ VARIABLE           *
      * FOR COMPUTATION                                             *
      ***************************************************************
               IF OUTM-IND = 1
                 PERFORM 17120-GET-OUTM-ADJ THRU
                           17120-GET-OUTM-ADJ-EXIT
                  VARYING OUTM-IDX2 FROM OUTM-IDX BY 1 UNTIL
                OUTM-CNTY(OUTM-IDX2) NOT = L-PSF-COUNTY-CODE
      ***************************************************************
      * FOR FYS 2018 AND AFTER, APPLY THE OUTMIGRATION ADJUSTMENT   *
      * ADD OUT MIGRATION ADJUST TO WAGE INDEX FOR NEW H-WINX       *
      ***************************************************************
                COMPUTE H-WINX = H-WINX + HLD-OUTM-ADJ
               END-IF.


       17100-INIT-EXIT.
           EXIT.

       17120-GET-OUTM-ADJ.
             IF OUTM-EFF-DATE(OUTM-IDX2) <= L-SERVICE-FROM-DATE AND
                OUTM-EFF-DATE(OUTM-IDX2) >= W-CY-BEGIN-DATE AND
                OUTM-EFF-DATE(OUTM-IDX2) <= W-CY-END-DATE
                 MOVE OUTM-ADJ-FACT(OUTM-IDX2) TO HLD-OUTM-ADJ
             END-IF.
       17120-GET-OUTM-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND APC / HCPCS/ FLAGS  *
      *                                                             *
      *  - SET FLAG IF APC = 5851/5852/5861/5862 (PARTIAL HOSP.)    *
      *  - SET FLAG IF PASS-THROUGH RADIOPHARMS(S) ON CLAIM         *
      *    (NEW FOR APRIL CY 2009 - ADDED 02/10/2009)               *
      *  - SET FLAG IF PASS-THROUGH CONTRAST AGENT(S) ON CLAIM      *
      *    (NEW FOR JANUARY CY 2010 - ADDED 11/15/2009)             *
      *  - SET FLAG IF CLAIM IS ELIGIBLE FOR DEVICE CREDIT          *
      *    (NEW FOR JANUARY CY 2014)                                *
      *  - SET FLAG IF CLAIM HAS A COMPREHENSIVE APC (C-APC) LINE   *
      *    (NEW FOR JULY 2016)                                      *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION HCPCS FROM     *
      *              0033 TO 0172 & 0173 FOR CY 2009                *
      *                                                             *
      * 11/12/2008 - HCPCS C1820 EXPIRED FROM PASS-THROUGH STATUS   *
      *              DECEMBER 2007, OFFSET FLAG LOGIC DISABLED      *
      *                                                             *
      * 08/02/2010 - ADDED LOGIC TO SET PASS-THOUGH DEVICE FLAG FOR *
      *              DEVICE OFFSETS AND POPULATE THE CORRESPONDING  *
      *              TABLE                                          *
      *                                                             *
      * 11/15/2010 - ADDED APCS 0175 & 0176 TO LIST OF PHP APCS     *
      *                                                             *
      * 11/18/2013 - ADDED LOGIC TO SET DEVICE CREDIT CLAIM FLAG    *
      *                                                             *
      * 11/17/2015 - REMOVED LOGIC TO SET FLAGS FOR PASS-THROUGH    *
      *              DEVICES (FOR OUTLIER & OFFSET LOGIC)           *
      *            - UPDATED PHP APCS FOR 2016                      *
      *            - REMOVED APC34-FLAG (MENTAL HEALTH) - NOT USED  *
      *            - REMOVED APC 0339 UNITS OVERRIDE                *
      *                                                             *
      * 05/09/2016 - ADDED LOGIC TO SET COMPREHENSIVE APC CLAIM FLAG*
      * 10/26/2016 - REMOVED PHP APC CHECK, PT RADIOPHARM CHECK,    *
      *              AND PT CONTRAST AGENT CHECK                    *
      *                                                             *
      ***************************************************************
       17125-INIT.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A COMPREHENSIVE APC     *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = 'J1' OR
                OPPS-SRVC-IND (LN-SUB) = 'J2'
                MOVE 'Y' TO C-APC-CLAIM-FLAG
             END-IF.


       17125-INIT-EXIT.
           EXIT.




      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0, 6, 7, OR 8  *
      *                (PAYMENT METHOD FLAG)                        *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       17150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 17250-CALC-DISCOUNT
                THRU 17250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 17150-INIT-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 10/26/2016 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG REMOVED         *
      *-------------------------------------------------------------*
             MOVE 'N' TO PKG-BLD-DED-LINE-FLAG.


      ***************************************************************
      *   IDENTIFY LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE ON       *
      *   A CLAIM WITH A COMPREHENSIVE APC; TREAT AS PACKAGED LINE  *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      ***************************************************************
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             END-IF.


      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR ' L' OR
                ' N' OR ' P' OR ' R' OR ' S' OR ' T' OR ' U' OR
                ' V' OR ' X' OR ' W' OR ' Y' OR ' Z' OR ' M' OR
                'J1' OR 'J2')
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 17150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' K' OR ' L' OR ' W' OR
                ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 17150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      * 10/26/2016- REMOVED PHP/MENTAL HEALTH CODE LISTS            *
      * 01/19/2017- ADDED '3' INTO LOGIC, FOR FISS INFORMATINAL USE *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF  OPPS-LITEM-DR-FLAG (LN-SUB) = ('0' OR '3') OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                       OPPS-LITEM-ACT-FLAG (LN-SUB) = '1'



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      * 11/03/2008 - REMOVED PAFS 91 - 99 FOR COMPOSITES FOR CY 2009*
      * 04/11/2011 - ADDED ' 9' & '10' AS VALID PAFS FOR CY 2011    *
      * 12/18/2014 - ADDED '11' FOR CY 2015                         *
      * 11/10/2015 - ADDED '12' - '14' FOR CY 2016                  *
      * 02/05/2016 - ADDED '16' - '20' FOR CY 2016                  *
      *              (PAF '15' RESERVED FOR FUTURE USE)             *
      * 08/11/2016 - ADDED '21' FOR CY 2016                         *
      * 10/16/2017 - ADDED '22' FOR CY 2018                         *
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8' OR ' 9' OR '10' OR '11'
                             OR '12' OR '13' OR '14'         OR '16'
                             OR '17' OR '18' OR '19' OR '20' OR '21'
                             OR '22' OR '23' OR '24'


      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *                                                             *
      *   ** SITE OF SERVICE FLAG = PAYMENT METHOD FLAG IN OCE **   *
      *                                                             *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', PHP APC IS ON THE CURRENT LINE       *
      *-------------------------------------------------------------*
      * 11/06/2007 - CHANGED PHP HEALTH CODES LISTED FROM           *
      *              APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008   *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION APC FROM       *
      *              0033 TO 0172 & 0173 FOR CY 2009, FLAG CHANGED  *
      *              FROM APC33-FLAG TO PHP-APC-FLAG                *
      * 10/19/2016 - ADDED VALUES '7' AND '8' FOR SECTION 603       *
      *              SERVICE LINES (MODIFIER 'PN')                  *
      * 10/26/2016 - REMOVED PHP SPECIFIC LOGIC                     *
      * 03/02/2017 - ADD PMF FLAG '9' VALUE TO VALID LIST           *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '9')



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE ALL PACKAGED COMPOSITE LINES                      *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *   11/12/2008 - CHANGED LOGIC THAT EXCLUDES ALL COMPOSITE    *
      *                LINES & MENTAL HEALTH PKG LINES TO USE THE   *
      *                COMPOSITE ADJUSTMENT FLAG INSTEAD OF PAYMENT *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *   05/09/2016 - ADDED LOGIC TO ENSURE BLOOD DEDUCTIBLE LINES *
      *                ON CLAIMS WITH A COMPREHENSIVE APC ARE       *
      *                INCLUDED                                     *
      *-------------------------------------------------------------*
                IF ( (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                     (OPPS-COMP-ADJ-FLAG (LN-SUB) = '00') ) OR
                     PKG-BLD-DED-LINE
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED REVENUE CODE 39X BLOOD LINE CHARGES   *
      *   (BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC)      *
      *   WHEN BILLED ON CLAIM WITH A COMPREHENSIVE APC TO          *
      *   DETERMINE THE PORTION OF THE BLOOD APC PAYMENT TO BE      *
      *   DISTRIBUTED TO THE BLOOD PRODUCT (PAF = 5) LINE FOR THE   *
      *   BLOOD DEDUCTIBLE CALCULATION                              *
      *-------------------------------------------------------------*
      *   05/16/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' N' AND
               (OPPS-LITEM-RVCD (LN-SUB) = '0390' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0392' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0399')
                  COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB) +
                                          H-TOT-38X-39X
             END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME (PACKAGED) COMPOSITE APC CHARGES     *
      *   FOR EACH COMPOSITE APC BY THE COMPOSITE ADJUSTMENT FLAG   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2007 - LOGIC REVISED FOR CY 2009 TO IDENTIFY ALL    *
      *                COMPOSITE LINES USING THE COMPOSITE          *
      *                ADJUSTMENT FLAG INSTEAD OF PAYMENT           *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *                (INCLUDES PROCESSING FOR MENTAL HEALTH       *
      *                 COMPOSITES)                                 *
      *-------------------------------------------------------------*
                IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "00" AND
                   OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "  " AND
                   OPPS-SRVC-IND (LN-SUB) = ' N'
                      PERFORM 17170-COMPOSITES
                         THRU 17170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   SET RETURN CODE & EXIT WHEN PACKAGED LINE/LINE APC = 0000 *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 17150-INIT-EXIT
                END-IF


      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 17150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 17175-APC-LOOKUP

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT METHOD FLAG = '8' (603 SV)*
      *   SET THE COINSURANCE AND REIMBURSEMENT TO PFS RATES        *
      *   10/16/2017 - NEW FOR CY 2018; 40% REDUCTION               *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * PFS-REDUCT-2018
                      END-IF

                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                         COMPUTE H-MIN-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         COMPUTE H-NAT-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         MOVE    PFS-REIM-RATE TO H-PPCT
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '14' (CT SCAN) *
      *   11/10/2015 - NEW FOR CY 2016; 5% REDUCTION                *
      *   07/15/2016 - NEW FOR CY 2017; 15% REDUCTION               *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '14'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * CT-REDUCT-2017
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '21' OR '23'  )*
      *   (XRAY SV)                                                 *
      *   08/11/2016 - NEW FOR CY 2017; 20% REDUCTION FOR FILM XRAY *
      *   01/08/2019 - ADDED PAF '23' RETRO ACTIVE 01/01/2017       *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ('21' OR '23')
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * XRAY-FILM-REDUCT-2017
                      END-IF


      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '22' OR '24'   *
      *   (X-RAY SV)                                                *
      *   07/18/2017 - NEW FOR CY 2018; 07% REDUCTION FOR CRT XRAY  *
      *   01/08/2019 - ADDED PAF '24' RETRO ACTIVE 01/01/2018       *
      *** REDUCTION RATE WILL CHANGE TO 10% FOR CY 2023         *****
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ('22' OR '24')
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * XRAY-CRT-REDUCT-2018
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT BY REDUCED UPDATE RATIO WHEN APPROPRIATE   *
      *   11/13/2009 - NEW FOR CY 2009 (QUALITY)                    *
      *   10/19/2016 - EXCLUDE 603 SERVICES FROM QUALITY REDUCTION  *
      *                (PMT METHOD FLAG = 7 OR 8)                   *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8'
                         PERFORM 17180-REDUCE-APC-PYMT
                            THRU 17180-REDUCE-APC-PYMT-EXIT
                      END-IF



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 17150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 17150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 17150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 17150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 17150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 17150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF LINES ELIGIBLE FOR DEVICE CREDIT *
      * WHEN THE CLAIM'S TOTAL DEVICE CREDIT IS > $0 AND THE LINE   *
      * HAS PAYMENT ADJUSTMENT FLAG '17'                            *
      * - REVISED DEVICE CREDIT LOGIC FOR APRIL 2016                *
      ***************************************************************
             IF H-CLAIM-DEVCR-AMT > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17'
                COMPUTE H-TOT-DEVCR-PYMTS =
                        H-TOT-DEVCR-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF TERMINATED PROCEDURE LINES       *
      * ELIGIBLE FOR DEVICE OFFSET WHEN PAYER ONLY VALUE CODE QQ    *
      * IS > $0 AND THE LINE HAS PAYMENT ADJUSTMENT FLAG '16'       *
      * (LINE MODIFIER IS 73)                                       *
      * - IMPLEMENTED IN APRIL 2016                                 *
      ***************************************************************
             IF L-PAYER-ONLY-VC-QQ > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16'
                COMPUTE H-TOT-TPDO-PYMTS =
                        H-TOT-TPDO-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE LINE CHARGES OF PASS-THROUGH DEVICE LINES        *
      * ASSOCIATED WITH PAYER ONLY VALUE CODES QN AND QO            *
      * - LINES WITH PAF '12' RECEIVE OFFSET IN VALUE CODE QN       *
      * - LINES WITH PAF '13' RECEIVE OFFSET IN VALUE CODE QO       *
      * - LINES WITH PAF '15' RECEIVE OFFSET IN VALUE CODE QP       *
      * NEW FOR CY2016 - 11/13/2015                                 *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
                COMPUTE H-QN-TOT-PTD-CHARGES =
                        H-QN-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
                COMPUTE H-QO-TOT-PTD-CHARGES =
                        H-QO-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *         COMPUTE H-QP-TOT-PTD-CHARGES =
      *                 H-QP-TOT-PTD-CHARGES +
      *                 OPPS-SUB-CHRG (LN-SUB)
      *      END-IF.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                PERFORM 17300-COIN-DEDUCT
                   THRU 17300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2009.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                SET W18BD-INDX TO 1
                SEARCH W18BD-ENTRY VARYING W18BD-INDX
                   AT END
                      GO TO 17150-INIT-EXIT
                   WHEN W-2018-BLOOD-HCPCS (W18BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-2018-BLOOD-RANK (W18BD-INDX) TO H-BLOOD-RANK
                     MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                     PERFORM 17375-BLOOD-DEDUCT
                        THRU 17375-BLOOD-DEDUCT-EXIT
                    END-IF.

       17150-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH COMPOSITE          *
      *  ADJUSTMENT FLAG NOT = '00' & POPULATE COMPOSITE APC TABLE  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY COMPOSITE ADJUSTMENT FLAG (CAF) -   *
      *    LOWEST TO HIGHEST FLAG VALUE (01 - NN)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH CAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *  11/12/2008 - LOGIC REVISED FOR CY 2009 TO USE THE          *
      *               COMPOSITE ADJUSTMENT FLAG INSTEAD OF THE      *
      *               PAYMENT ADJUSTMENT FLAG, VARIABLE H-CMP-CAF   *
      *               HOLDS COMPOSITE ADJUSTMENT FLAG, VARIABLE     *
      *               W-CMP-PAF RETAINED AND NOW HOLDS THE CAF      *
      *               (RETAINED TO CONTINUE USE OF EXISTING TABLE)  *
      *                                                             *
      ***************************************************************
       17170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S COMPOSITE ADJUSTMENT FLAG FOR TABLE SEARCH   *
      *-------------------------------------------------------------*
             MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE CAF         *
      *-------------------------------------------------------------*
                PERFORM 17171-SEARCH-CAF
                   THRU 17171-SEARCH-CAF-EXIT.

       17170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       17171-SEARCH-CAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS NOT      *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 17172-ADD-ENTRY
                      THRU 17172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS ALREADY  *
      * IN THE TABLE, UPDATE THE ENTRY                              *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                   PERFORM 17173-UPDATE-ENTRY
                      THRU 17173-UPDATE-ENTRY-EXIT.

       17171-SEARCH-CAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       17172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS COMPOSITE ADJUSTMENT FLAG (CAF) - LOWEST TO HIGHEST CAF *
      *-------------------------------------------------------------*
             PERFORM 17174-STAGE-CMP-ENTRY
                THRU 17174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-CAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-CAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       17172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * COMPOSITE ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE       *
      *                                                             *
      ***************************************************************
       17173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE CAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       17173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER CAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       17174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       17174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       17175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 17175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       17175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      REDUCE APC PAYMENT OF LINES FROM PROVIDERS WITH A      *
      *      SPACE IN THE QUALITY INDICATOR FIELD OF THE OPSF       *
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      *  11/16/2010 - ADDED SI = U (BRACHY) TO LOGIC                *
      *                                                             *
      ***************************************************************
       17180-REDUCE-APC-PYMT.

      *-------------------------------------------------------------*
      *  SPECIFY LINES ELIGIBLE FOR REDUCTION                       *
      *  11/13/2019- QUALITY ADJUSTMENT EXCLUSION FOR NEW TECHNOLOGY*
      *  CATEGORY APC RANGES:                                       *
      *             - 1575-1599 (EFF. 1/1/2016)                     *
      *             - 1901-1906 (EFF. 1/1/2017)                     *
      *             - 1907-1908 (EFF. 1/1/2018)                     *
      *-------------------------------------------------------------*
             IF ( L-PSF-HOSP-QUAL-IND = ' ' )  AND

                (  (OPPS-SRVC-IND (LN-SUB) = ' P')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' R')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' S' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01491' AND
                           OPPS-GRP (LN-SUB) <= '01537') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01575' AND
                           OPPS-GRP (LN-SUB) <= '01585') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01908'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' T' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01539' AND
                           OPPS-GRP (LN-SUB) <= '01574') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01589' AND
                           OPPS-GRP (LN-SUB) <= '01599') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01908'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' U')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' V')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' X')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J1')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J2')  ) THEN

                COMPUTE H-APC-PYMT ROUNDED = H-APC-PYMT * 0.980
                MOVE 11 TO A-RETURN-CODE (LN-SUB)

             END-IF.


       17180-REDUCE-APC-PYMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       17200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   IF W-WINX-LOOKUP
                      MOVE  50  TO A-CLM-RTN-CODE
                   END-IF
                   GO TO 17200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA

      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 17210-WAGE-LOOKUP.

      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0 OR NOT NUMERIC             *
      *   *AND* NOT ON RURAL FLOOR LOOKUP                           *
      ***************************************************************

             IF (H-WINX = 0 OR H-WINX NOT NUMERIC) AND
                 W-WINX-LOOKUP THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       17200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       17210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE MEETS THE CRITERIA:       *
      *  - MUST NOT BE AFTER THE LATEST WAGE INDEX EFFECTIVE DATE   *
      *    THAT CAN BE USED BY THE CLAIM                            *
      *  - EXCEPT FOR INDIAN HEALTH PROVIDERS (CBSAS 98 AND 99),    *
      *    MUST BE WITHIN THE CLAIM'S CALENDAR YEAR                 *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD / LATEST         *
      *   EFFECTIVE DATE FOR THE CBSA)                              *
      ***************************************************************
             MOVE WCW-DTCD (W-SUB3) TO W-WCW-DTCD.

             IF W-WCW-DTCD NOT > WCD-DTCD (WCD-SUB) AND

                ( (WCD-DATE (W-WCW-DTCD) >= W-CY-BEGIN-DATE AND
                   WCD-DATE (W-WCW-DTCD) <= W-CY-END-DATE AND
                   H-PSF-CBSA NOT = '   98' AND
                   H-PSF-CBSA NOT = '   99') OR

                  (H-PSF-CBSA = '   98' OR
                   H-PSF-CBSA = '   99') )

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *   *ONLY VALID FOR WAGE INDEX LOOKUP, NOT RURAL FLOOR*       *
      *   IF WAGE INDEX > FLOOR, OVERWRITE H-WINX                   *
      *-------------------------------------------------------------*
                IF L-PSF-SPEC-PYMT-IND = 'Y' AND W-WINX-LOOKUP THEN
                   IF WCW-WINX2 (W-SUB3) > H-WINX THEN
                      MOVE WCW-WINX2 (W-SUB3) TO H-WINX
                   END-IF
      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *   IF WAGE INDEX > FLOOR OR LOOKING UP RURAL FLOOR, STORE    *
      *   RESULT IN H-WINX.                                         *
      *-------------------------------------------------------------*
                ELSE
                   IF (WCW-WINX1 (W-SUB3) > H-WINX OR W-FLOOR-LOOKUP)
                      MOVE WCW-WINX1 (W-SUB3) TO H-WINX
                   END-IF
                END-IF


      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE DID NOT MEET THE CRITERIA *
      *  - AFTER THE LATEST EFFECTIVE DATE THE CLAIM CAN USE -OR-   *
      *  - NOT WITHIN THE CLAIM'S CALENDAR YEAR AND NOT IN CBSA     *
      *    98 OR 99                                                 *
      *  GO TO THE PRIOR RECORD FOR THIS CBSA WITH AN EARLIER DATE  *
      *  IN THE CBSA WAGE INDEX TABLE.                              *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *  AGAIN AND REPEAT THE PROCESS
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 17210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      * >10-28-2014 ONLY VALID FOR WAGE INDEX PASS, NOT RURAL FLOOR *
      *-------------------------------------------------------------*
                ELSE

                   IF W-WINX-LOOKUP
                      MOVE 0 TO H-WINX
                END-IF
             END-IF.

       17210-WAGE-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       17250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 17250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       17250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       17300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 17350-STAGE-ENTRY
                THRU 17350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX      TO W-WINX (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       17300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       17350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       17350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       17375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 17385-STAGE-ENTRY
                THRU 17385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX     TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       17375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       17385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       17385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PAYMENTS, DEDUCTIBLES, REIM., & COINSURANCE,*
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       17400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 17400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 17550-CALC-STANDARD
                   THRU 17550-CALC-STANDARD-EXIT
             ELSE
                GO TO 17400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRUG COINSURANCE TABLE FOR LATER PROCESSING        *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET BLOOD-FLAG WHEN SERVICE INDICATOR = R (BLOOD)        *
      *  - EXCLUDE PACKAGED BLOOD DEDUCTIBLE LINES & SECTION 603    *
      *    SERVICE LINES                                            *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30 AND
                NOT PKG-BLD-DED-LINE AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                PERFORM 17450-ADJ-PROC-COIN
                   THRU 17450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 17500-ADJ-CHRGS
                THRU 17500-ADJ-CHRGS-EXIT.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

                COMPUTE A-DEVICE-CREDIT-QD =
                        A-DEVICE-CREDIT-QD + H-LINE-DEVCR-AMT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 15840-PROCESS-TYPE2     *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)

               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       17400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      POPULATE COINSURANCE CAP ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: BLOOD LINE                              *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY BLOOD LINE         *
      *                                                             *
      * COINSURANCE RECORD COMBINATIONS:                            *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       BLOOD ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT   *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO BLOOD ADMINISTERED ON THE   *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH BLOOD ADMINISTERED ON THE      *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = R =>               *
      *       BLOOD ADMINSTERED ON THE DATE OF SERVICE              *
      *                                                             *
      ***************************************************************
       17450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                PERFORM 17455-SEARCH-KEY
                   THRU 17455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = R LINES (BLOOD)                                *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET BLOOD-FLAG TO INDICATE BLOOD LINE                       *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO BLOOD-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                   PERFORM 17455-SEARCH-KEY
                      THRU 17455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY BLOOD LINE)*
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = R       *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW BLOOD COINSURANCE ENTRY             *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 17475-STAGE-DCP-ENTRY
                      THRU 17475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, BLOOD                                        *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       17450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COINSURANCE CAP ROLL-UP TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       17455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH COINSURANCE CAP TABLE STARTING AT ENTRY #1           *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 17460-ADD-ENTRY
                      THRU 17460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 17465-UPDATE-ENTRY
                      THRU 17465-UPDATE-ENTRY-EXIT.

       17455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE COINSURANCE TABLE                                       *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       17460-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COINSURANCE CAP TABLE ENTRY         *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 17475-STAGE-DCP-ENTRY
                THRU 17475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, BLOOD                                        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       17460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COINSURANCE RECORD WITH THE SAME        *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       17465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR BLOOD LINES - ACCUMULATE DAY'S TOTAL BLOOD COIN DUE     *
      * -REMOVE ' G' & ' K'                                         *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A BLOOD LINE, UPDATE THE RECORD   *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 17485-REPLACE-TYPE1
                     THRU 17485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 17480-RANK-COIN
                     THRU 17480-RANK-COIN-EXIT.

       17465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COINSURANCE RECORD WITH A HIGHER          *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       17475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       17475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST ACTUAL     *
      * COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE           *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *  CHANGED TO ACTUAL FROM NATIONAL COINSURANCE FOR 2018       *
      ***************************************************************
       17480-RANK-COIN.

             IF H-NEW-COIN > W-DCP-COIN1 (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       17480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = R        *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = BLOOD LINE NEW COINSURANCE AMOUNT(S)              *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       17485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       17485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 15600-ADJ-CHRG-OUTL.)                     *
      *                                                             *
      ***************************************************************
       17500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
      * 12/18/2009 - ADD SIS R & U, WHICH ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P' OR ' R' OR ' U' OR 'J1' OR 'J2')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                AND NOT PKG-BLD-DED-LINE
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       17500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    & TAKE PT DEVICE OFFSET WHEN APPLICABLE                  *
      * 5. CALCULATE AND APPLY DEVICE CREDIT                        *
      *                                                             *
      ***************************************************************
       17550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 17655-SET-BD-HCPCS-FLAG
                THRU 17655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      *   FLAG LINE IF ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND CLAIM  *
      *   HAS A COMPREHENSIVE APC; TREAT AS PACKAGED LINE           *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             ELSE
                  MOVE 'N' TO PKG-BLD-DED-LINE-FLAG
             END-IF.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).


      ***************************************************************
      * CALCULATE DEVICE CREDIT FOR ELIGIBLE LINE(S)                *
      *-------------------------------------------------------------*
      * 02/09/2016- REVISED LOGIC IMPLEMENTED IN APRIL 2016         *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-CLAIM-DEVCR-AMT > 0 AND
                H-TOT-DEVCR-PYMTS > 0
                PERFORM 17550-DEVICE-CREDIT
                   THRU 17550-DEVICE-CREDIT-EXIT.


      ***************************************************************
      * CALCULATE DEVICE OFFSET FOR ELIGIBLE TERMINATED PROCEDURE   *
      * LINES AND REDUCE THE APC PAYMENT BY THE DEVICE OFFSET AMOUNT*
      *-------------------------------------------------------------*
      * 02/09/2016- NEW LOGIC IMPLEMENTED IN APRIL 2016             *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16' AND
                L-PAYER-ONLY-VC-QQ > 0 AND
                H-TOT-TPDO-PYMTS > 0
                PERFORM 17550-TERM-PROC-DEV-OFF
                   THRU 17550-TERM-PROC-DEV-OFF-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, X, J1, OR J2 LINES   *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      * 10/26/2016 - STOPPED PERFORMING PHP OUTLIER CAPPING LOGIC   *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X' OR
                 'J1' OR 'J2') THEN
                  PERFORM 17550-SCH-ADJ
                     THRU 17550-SCH-ADJ-EXIT
                  PERFORM 17560-CALC-BENE-DEDUCT
                     THRU 17560-CALC-BENE-DEDUCT-EXIT


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (PT DEVICE) LINES, PAYMENT IND.*
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      *-------------------------------------------------------------*
      * 01/01/2009 - BRACHYTHERAPY SERVICES ADDED FOR CY 2009       *
      * 11/15/2009 - BRACHYTHERAPY SERVICES (SI=U) REMOVED CY 2010  *
      *            - THERAPEUTIC RADIOPHARMS' SI NOT 'H' FOR CY2010 *
      * 08/11/2010 - NEW PASS-THROUGH DEVICE OFFSET LOGIC ADDED IN  *
      *              PARAGRAPH 10555-CALC-H-STANDARD                *
      * 11/16/2015 - REVISED PT-DEVICE LOGIC: 15555-CALC-H-STANDARD *
      ***************************************************************
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' H') THEN
                 IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                       OPPS-PYMT-IND (LN-SUB) = ' 6')
                   PERFORM 17555-CALC-H-STANDARD
                      THRU 17555-CALC-H-STANDARD-EXIT
                   PERFORM 17560-CALC-BENE-DEDUCT
                      THRU 17560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 17550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = R & U LINES; THE PMT. IND.       *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      * 11/15/2009 - ADDED BRACHYTHERAPY SERVICES (SI=U) FOR CY2010 *
      *              THERAPEUTIC RADIOPHARMS' SI=K FOR CY 2010      *
      * 11/16/2009 - ADD LOGIC TO ADJUST PT CONTRAST AGENT HCPCS    *
      *              LINE PAYMENT BY OFFSET                         *
      * 05/10/2016 - CALCULATE BLOOD DEDUCTIBLE & LINE PAYMENT FOR  *
      *              BLOOD DEDUCTIBLE LINES ON COMPREHEMSIVE APC    *
      *              CLAIMS (THESE LINES WERE PREVIOUSLY PACKAGED)  *
      *            - ADD LOGIC TO EXEMPT BLOOD DEDUCTIBLE LINES ON  *
      *              COMPREHENSIVE APC CLAIMS FROM REIM, COIN, &    *
      *              NON-BLOOD DEDUCTIBLE CALCS.                    *
      * 10/21/2016 - NO LONGER CALCULATE PAYMENT FOR SI G & K LINES *
      *              (DRUGS) IN PRICER; NOW CALCULATED IN FISS      *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 17550-CALC-RU
                         THRU 17550-CALC-RU-EXIT

                      IF PKG-BLD-DED-LINE
                         NEXT SENTENCE
                      END-IF

                      PERFORM 17560-CALC-BENE-DEDUCT
                         THRU 17560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 17550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      * 11/12/2008 - BRACHYTHERAPY SOURCE'S STATUS INDICATOR = ' U' *
      *              EFFECTIVE 1/1/2009                             *
      *                                                             *
      * 11/16/2009 - REMOVED LOGIC FOR THERAPEUTIC RADIOPHARMS &    *
      *              BRACHYTHERAPY SOURCES B/C THESE ARE NOT PAID   *
      *              AT COST FOR CY 2010                            *
      *                                                             *
      * 04/11/2011 - ADDED LOGIC TO PREVENT LINES WITH PAFS 9 OR 10 *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      * 05/13/2016 - ADDED LOGIC FOR BLOOD DEDUCTIBLE LINES ON A    *
      *              COMPREHENSIVE APC CLAIM (ZERO OUT REIM, COIN,  *
      *              & NON-BLOOD DEDUCTIBLE)                        *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * FOR BLOOD DEDUCTIBLE LINES ON A COMPREHENSIVE APC CLAIM:    *
      * SET REIMBURSEMENT, COINSURANCE, & DEDUCTIBLE AMOUNTS TO $0  *
      *-------------------------------------------------------------*
             IF PKG-BLD-DED-LINE
                MOVE 0 TO H-LITEM-REIM
                          H-TOTAL-LN-DEDUCT
                          H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 17550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE REIMBURSEMENT AND SET COINSURANCE AMOUNTS TO $0   *
      * FOR LINES WITH A PAF= 9 OR 10 OR 23 OR 24                   *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 9' OR '10' OR '23'
                                                OR '24')
                COMPUTE H-LITEM-REIM ROUNDED =
                   H-LITEM-PYMT - H-TOTAL-LN-DEDUCT
                MOVE 0 TO H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 17550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                  H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX).
      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * FOR SECTION 603 SERVICES -                                  *
      * SET MIN, MAX, AND REDUCED COINSURANCE TO PSF STANDARD       *
      * FOR LINES WITH A PMF= 7 OR 8                                *
      *-------------------------------------------------------------*
             IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                COMPUTE H-MIN-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                COMPUTE H-MAX-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                MOVE 0  TO H-RED-COIN

                GO TO 17550-CALC-STANDARD-EXIT
             END-IF.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DEVICES, BRACHYTHERAPY, & BLOOD                             *
      * (SI = H LINES HAVE A MIN-COIN = 0, WON'T ENTER LOGIC)       *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) =
                  ' H' OR ' R' OR ' U'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       17550-CALC-STANDARD-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE LINE'S DEVICE CREDIT AMOUNT                   *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - REVISED LOGIC IMPLEMENTED APRIL 2016           *
      *                                                             *
      ***************************************************************
       17550-DEVICE-CREDIT.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE CREDIT     *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-DEVCR-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-DEVCR-PYMTS.

           COMPUTE H-LINE-DEVCR-AMT ROUNDED =
                   H-CLAIM-DEVCR-AMT * H-LINE-DEVCR-PYMT-RATE.

       17550-DEVICE-CREDIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE TERMINATED PROCEDURE LINE'S DEVICE OFFSET     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - NEW FOR CY 2016 (APRIL IMPLEMENTATION)         *
      *                                                             *
      ***************************************************************
       17550-TERM-PROC-DEV-OFF.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE OFFSET     *
      * FOR TERMINATED PROCEDURES                                   *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-TPDO-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-TPDO-PYMTS.

           COMPUTE H-LINE-TPDO-AMT ROUNDED =
                   L-PAYER-ONLY-VC-QQ * H-LINE-TPDO-PYMT-RATE.

      *-------------------------------------------------------------*
      * ADJUST THE BASE APC PAYMENT BY THE DEVICE OFFSET            *
      *-------------------------------------------------------------*
           IF W-APC-PYMT (W-LP-INDX) >= H-LINE-TPDO-AMT
              COMPUTE W-APC-PYMT (W-LP-INDX) ROUNDED =
                      W-APC-PYMT (W-LP-INDX) - H-LINE-TPDO-AMT
           ELSE
              MOVE 0 TO W-APC-PYMT (W-LP-INDX)
           END-IF.

       17550-TERM-PROC-DEV-OFF-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *        FOR LINES WITH A SI OF S, V, T, P, X, R, OR U        *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA OR THE     *
      *   L-PSF-PYMT-CBSA MUST BE A VALUE OF                        *
      *   '   01' THRU '   99' AND THE L-PSF-PROV-TYPE              *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2017: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      * 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES (SI=R)     *
      *              ADDED TO LOGIC.  BRACHY LINES NOT PROCESSED IN *
      *              PARAGRAPH & NOW HAVE A SI = U, SI = K LOGIC    *
      *              REMOVED FROM THIS PARAGRAPH.                   *
      * 05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD    *
      *              DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.     *
      *              FIX EFFECTIVE RETROACTIVE TO 01/01/2009.       *
      * 11/17/2009 - BRACHYTHERAPY LINES NOW PROCESSED IN THIS      *
      *              PARAGRAPH FOR CY 2010 (SI=U), DO NOT RECEIVE   *
      *              WAGE ADJUSTMENT                                *
      * 05/09/2011 - REVISED LOGIC TO EXCLUDE BILL TYPE 14X FROM    *
      *              RECEIVING THE SCH ADD-ON                       *
      * 02/07/2012 - REPLACE BILL14X-FLAG WITH CONDITION NAME       *
      *              BILL-TYPE-14X                                  *
      * 01/27/2014 - WHEN APPLICABLE, SUBTRACT DEVICE CREDIT        *
      *              AMOUNT FROM LINE ITEM PAYMENT                  *
      * 10/21/2016 - EXCLUDE SECTION 603 SERVICE LINES FROM SCH ADJ *
      * 06/12/2017 - IF THE GEOGRAPHIC, WAGE INDEX, OR PAYMENT CBSA *
      *              IS RURAL, APPLY THE RURAL SCH ADJ. TO THE LINE *
      *              PAYMENT. ADDED L-PSF-PYMT-CBSA CY2017          *
      ***************************************************************
       17550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.
             MOVE L-PSF-PYMT-CBSA TO PYMT-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      *   - SECTION 603 SERVICES EXCLUDED FROM THE SCH ADJUSTMENT   *
      ***************************************************************

             IF (RURAL-GEO OR RURAL-WI OR RURAL-PYMT) AND
                (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22') AND
                (NOT BILL-TYPE-14X) AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7') AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8')
      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*

                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      ***************************************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = R (BLOOD) OR U (BRACHY) LINES ARE NOT WAGE-ADJUSTED    *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U'
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.
      *-------------------------------------------------------------*
      * REDUCE ADJUSTED APC PAYMENT BY DEVICE CREDIT IF APPLICABLE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-LINE-DEVCR-AMT > 0
                IF H-LITEM-PYMT >= H-LINE-DEVCR-AMT
                   COMPUTE H-LITEM-PYMT ROUNDED =
                           H-LITEM-PYMT - H-LINE-DEVCR-AMT
                ELSE
                   MOVE 0 TO H-LITEM-PYMT
                END-IF
             END-IF.


       17550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = R & U LINES:         *
      *   - APC PAYMENT FOR BLOOD LINES (SI = R)                    *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = U LINES                      *
      *   - SCH ADJUSTMENT APPLIED TO BLOOD & BRACHY LINES          *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      * - 11/12/2008 - FOR CY 2009, BRACHYS NOT PROCESSED IN THIS   *
      *   PARAGRAPH; BRACHY LINES ASSIGNED A NEW SI OF ' U'         *
      * - 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES HAVE A   *
      *   SI = R                                                    *
      * - 12/05/2008 - MODIFIED LOGIC TO SEND BLOOD LINES WITHOUT   *
      *   A PMT ADJ FLAG = 5 OR 6 TO THE SCH ADJUSTMENT PARAGRAPH,  *
      *   INCLUDED SI = R IN THE BLOOD IDENTIFICATION LOGIC         *
      * - 11/15/2009 - BRACHYTHERPY SERVICES (SI = U) & THERAPEUTIC *
      *   RADIOPHARMS (SI = K) SENT TO THIS PARAGRAPH FOR CY 2010,  *
      *   LOGIC ALTERED TO PROCESS SI = U (RECEIVE REGULAR APC PMT) *
      * - 11/17/2009 - SEND BRACHYTHERAPY LINES TO 10550-SCH-ADJ TO *
      *   MAKE ELIGIBLE FOR SCH ADJUSTMENT, NOT WAGE ADJUSTED       *
      * - 05/10/2016 - ADDED LOGIC FOR SPECIAL HANDLING OF BLOOD    *
      *   DEDUCTIBLE LINES ON CLAIMS WITH A COMPREHENSIVE APC       *
      * - 11/2016 - REMOVED LOGIC FOR SI = G & K LINES (DRUGS)      *
      *                                                             *
      ***************************************************************
       17550-CALC-RU.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 17550-SET-BLOOD-FRACTION
                     THRU 17550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 17550-ADJ-BLOOD-COST
                     THRU 17550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 17550-SCH-ADJ
                     THRU 17550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * CHANGE THE PAYMENT OF THE BLOOD DEDUCTIBLE LINE ON THE SAME *
      * CLAIM AS A COMPREHENSIVE APC TO THE BLOOD DEDUCTIBLE AMOUNT *
      *-------------------------------------------------------------*
                  IF PKG-BLD-DED-LINE
                      MOVE H-LN-BLOOD-DEDUCT TO H-LITEM-PYMT
                  END-IF

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE, BUT PAF = 5 OR 6           *
      * (BLOOD PROCESSING AND PRODUCT BILLED TOGETHER)              *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 17550-ADJ-PLATE-COST
                      THRU 17550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 17550-SCH-ADJ
                      THRU 17550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE AND PAF NOT EQUAL TO 5 OR 6 *
      * (ONLY BLOOD PRODUCT BILLED)                                 *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 12/05/2008 - 7550-SCH-ADJ PERFORM ADDED FOR BLOOD LINES     *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 17550-SCH-ADJ
                      THRU 17550-SCH-ADJ-EXIT
                ELSE
                   IF OPPS-SRVC-IND (LN-SUB) = ' U'
                      PERFORM 17550-SCH-ADJ
                         THRU 17550-SCH-ADJ-EXIT
                   END-IF
                END-IF
             END-IF
             END-IF.

       17550-CALC-RU-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       17550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       17550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       17550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       17550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       17550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       17550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *           CALCULATE PAYMENT FOR PAID AT COST LINES          *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 08-11-2010 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED       *
      * 11-17-2015 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED AGAIN *
      * 08-18-2016 - USE DEVICE CCR WHEN AVAILABLE                  *
      *                                                             *
      ***************************************************************
       17555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST - "PAID AT COST"         *
      * (IF NO DEVICE CCR USE HOSPITAL CCR)                         *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

              IF L-PSF-DEVICE-CCR = 0
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG *  L-PSF-OPCOST-RATIO)
              ELSE
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG * L-PSF-DEVICE-CCR)
              END-IF.

      *-------------------------------------------------------------*
      * FOR PASS-THROUGH DEVICE LINE WITH AN ASSOCIATED OFFSET,     *
      * APPLY THE OFFSET (INDICATED BY PAF = '12' OR '13' OR '15'   *
      * (NOT CURRENTLY USING PAF '15')                              *
      *-------------------------------------------------------------*
              IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12' OR
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13' OR
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
                 PERFORM 17556-CALC-PTD-OFFSET
                    THRU 17556-CALC-PTD-OFFSET-EXIT
              END-IF.

      *-------------------------------------------------------------*
      * CAPTURE PAYMENT AMOUNT                                      *
      *-------------------------------------------------------------*
             IF T-LITEM-PYMT < 0 THEN
                MOVE 0 TO H-LITEM-PYMT
             ELSE
                MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

       17555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *   REDUCE LINE ITEM PAYMENTS OF PASS-THROUGH DEVICES THAT    *
      * HAVE AN ASSOCIATED PROCEDURE ON THE CLAIM BY THE PROCEDURE  *
      *                WAGE-ADJUSTED OFFSET AMOUNT                  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ** EFFECTIVE 11/13/2015 - REVISED PT DEVICE OFFSET LOGIC    *
      *                                                             *
      ***************************************************************
       17556-CALC-PTD-OFFSET.

      *-------------------------------------------------------------*
      * DETERMINE WHICH VARIABLES TO USE IN CALCULATIONS            *
      *-------------------------------------------------------------*
            INITIALIZE H-TOT-PTD-CHARGES
                       H-WA-PTD-OFFSET.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
               MOVE H-QN-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QN-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
               MOVE H-QO-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QO-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *     IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *        MOVE H-QP-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
      *        MOVE H-QP-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
      *     END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHAT % OF THE OFFSET WILL BE APPLIED              *
      *-------------------------------------------------------------*
            IF H-TOT-PTD-CHARGES > 0
               COMPUTE W-PTDO-CHRG-RATE ROUNDED =
                       H-SUB-CHRG / H-TOT-PTD-CHARGES
            ELSE
               GO TO 17556-CALC-PTD-OFFSET-EXIT
            END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE TAKEN                     *
      *-------------------------------------------------------------*
            COMPUTE W-PTDO-LINE-OFFSET ROUNDED =
                    W-PTDO-CHRG-RATE *
                    H-WA-PTD-OFFSET.

      *-------------------------------------------------------------*
      * SUBTRACT THE OFFSET AMOUNT FROM THE LINE PAYMENT            *
      *-------------------------------------------------------------*
            IF W-PTDO-LINE-OFFSET <= T-LITEM-PYMT
               COMPUTE T-LITEM-PYMT ROUNDED =
                       T-LITEM-PYMT - W-PTDO-LINE-OFFSET
            ELSE
               MOVE 0 TO T-LITEM-PYMT
            END-IF.


       17556-CALC-PTD-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       17560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * LINES INELIGIBLE FOR DEDUCTIBLE SKIP DEDUCTIBLE CALCULATION *
      * EFF. 7/1/2009 - CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      * ASSIGNED A PAF = ' 4'                                       *
      * - 04/11/2011 - ADDED PAF 9 FOR SERVICES WHERE THE           *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *   (ADDED FOR PREVENTIVE SERVICES WAIVER IN CY 2011)         *
      * - 01/14/2019 - ADDED PAF 23 & 24                            *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 4' OR ' 9' OR '23'
                                                OR '24')
                GO TO 17560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       17560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      * - 11/12/2008: FOR CY 2009, BRACHYS SI = U AND BLOOD SI = R  *
      *   BRACHY INELIGIBLE FOR OUTLIER, BLOOD ELIGIBLE FOR OUTLIER *
      *                                                             *
      * - 12/05/2008: ADDED SI = K TO LIST OF SIS INELIGIBLE FOR    *
      *   OUTLIER (BRACHYS & BLOOD NO LONGER HAVE SI = K)           *
      *                                                             *
      * - 11/17/2009: REMOVED U FROM LIST OF SIS INELIGIBLE FOR     *
      *   OUTLIER; BRACHYS NOW ELIGIBLE B/C NOT PAID AT COST CY 2010*
      *                                                             *
      * - 12/16/2009: ADDED SIS R AND U TO LOGIC THAT DISTRIBUTES   *
      *   PACKAGED CHARGES TO PAYABLE LINES. V2010.1.2              *
      *                                                             *
      * - 11/04/2011: MODIFIED LOGIC TO APPLY THE PHP CAP ONLY TO   *
      *   PHP CMHC LINES, NOT PHP HOSPITAL LINES PER POLICY'S       *
      *   INSTRUCTIONS                                              *
      *                                                             *
      * - 11/17/2015: MODIFIED LOGIC TO STOP ACCOUNTING FOR         *
      *   PASS-THROUGH DEVICE PAYMENTS AND CHARGES IN ASSOCIATED    *
      *   PROCEDURE'S OUTLIER CALCULATION.  ADDED STATUS INDICATOR  *
      *   'J2' AS ELIGIBLE FOR OUTLIER AND TO RECEIVED PACKAGED     *
      *   CHARGES                                                   *
      *                                                             *
      * - 05/10/2016: ADDED LOGIC TO EXCLUDE LINES ELIGIBLE FOR THE *
      *   BLOOD DEDUCTIBLE AND ON A CLAIM WITH A COMPREHENSIVE APC  *
      *   FROM THE OUTLIER PAYMENT                                  *
      *                                                             *
      * - 10/21/2016: ADDED LOGIC TO EXCLUDE SECTION 603 SERVICE    *
      *   LINES FROM THE OUTLIER PAYMENT (PMF = 7 OR 8)             *
      *                                                             *
      ***************************************************************
       17600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * SERVICE LINES NOT ELIGIBLE FOR AN OUTLIER PAYMENT:          *
      *   DEVICES, PACKAGED, PACKAGED AS PART OF DRUG ADMIN, AND    *
      *   SECTION 603 SERVICES                                      *
      *-------------------------------------------------------------*
      * 11/12/2008 - BRACHY (SI=U) ADDED TO LIST                    *
      * 12/05/2008 - SI K ADDED TO THE LIST                         *
      * 11/16/2009 - REMOVED PAF=2 FROM BRACHY (SI=U) CRITERIA      *
      * 11/17/2009 - REMOVE SI=U, BRACHYS ARE ELIGIBLE FOR OUTLIER  *
      * 07/26/2016 - REMOVE SI=G SI=K                               *
      * 10/21/2016 - SECTION ADDED 603 SERVICES (PMF = 7 OR 8)      *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' H' OR ' N') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8')
                   GO TO 17600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * BLOOD LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND ON A      *
      * CLAIM WITH A COMPREHENSIVE APC NOT ELIGIBLE FOR OUTLIER     *
      *-------------------------------------------------------------*
      * 05/10/2016 - NEW FOR JULY 2016                              *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  GO TO 17600-ADJ-CHRG-OUTL-EXIT
             END-IF.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                           ' X' OR ' P' OR ' R' OR
                                           ' U' OR 'J1' OR 'J2') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                          ' X' OR ' P' OR ' R' OR
                                          ' U' OR 'J1' OR 'J2') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A COMPOSITE ADJ.     *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 01 - NN...) ARE ACCUMULATED BY COMPOSITE            *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME        *
      * (PAYABLE) LINE'S CHARGES.                                   *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2007 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      * 11/12/2008 - CHANGED LOGIC TO USE THE COMPOSITE ADJUSTMENT  *
      *              FLAG INSTEAD OF THE PAYMENT ADJUSTMENT FLAG    *
      *              VALUES 91 - 99 TO ID PRIME COMPOSITE LINES     *
      ***************************************************************

      *-------------------------------------------------------------*
      * COMPOSITE ADJUSTMENT FLAG > 0 INDICATES COMPOSITE APC       *
      *-------------------------------------------------------------*
           IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = '00'

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.


      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD                          *
      *   (ALWAYS USE THE PHP "CAP" APC'S WAGE ADJ PMT FOR PHP LINES*
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED BECAUSE PAYMENTS MAY BE ADJUSTED FOR     *
      *              PASS-THROUGH DEVICES                           *
      * ??/??/2008 - NEW FOR CY 2009 - ALWAYS USE THE PHP "CAP"     *
      *              APC'S WAGE ADJ "CAP" PMT FOR PHP LINES (SI=P)  *
      * 11/04/2011 - ONLY APPLY PHP "CAP" TO CMHC LINES; PER        *
      *              POLICY'S INSTRUCTIONS PHP HOSPITAL LINES ARE   *
      *              NOT CAPPED.                                    *
      * 11/17/2015 - CONTINUE TO USE THIS LOGIC EVEN THOUGH PAYMENTS*
      *              ARE NO LONGER ADJUSTED FOR PT DEVICES          *
      * 10/26/2016 - DISABLED CMHC PHP PMT CAP BECAUSE ALL PHP CMHCS*
      *              USE THE SAME APC EFFECTIVE JANUARY 2017        *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL.


      ***************************************************************
      *                                                             *
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      * -NEW FOR JANUARY 2009                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE PHP "CAP" APC'S LINE PAYMENT                        *
      *                                                             *
      * -NEW FOR JANUARY 2017                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE SAME PHP APC (NO NEED TO CAP PMT)                   *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      * (CMHC PROVIDERS ONLY PROCESS PARTIAL HOSPITALIZATION LINES) *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT

      ***************************************************************
      *     ADD LOGIC TO PREVENT NEGATIVE OUTLIER PAYMENT           *
      ***************************************************************
                   IF H-LITEM-OUTL-PYMT < 0
                      MOVE 0 TO H-LITEM-OUTL-PYMT
                   END-IF


      *-------------------------------------------------------------*
      *     FOR CMHC PROVIDERS THAT ARE SUBJECT TO THE OUTLIER CAP, *
      *     ACCUMULATE CLAIM PAYMENT AND OUTLIER TOTALS             *
      *-------------------------------------------------------------*
                   IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '0'
                        COMPUTE H-CMHC-PYMT-TOTAL =
                          H-CMHC-PYMT-TOTAL + H-LITEM-PYMT-OUTL

                        COMPUTE H-CMHC-OUTL-TOTAL =
                          H-CMHC-OUTL-TOTAL + H-LITEM-OUTL-PYMT
                   END-IF

      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE

                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 4150)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT
                  END-IF
               END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT.


      *-------------------------------------------------------------*
      * LINES THAT ARE NOT ELIGIBLE FOR AN OUTLIER PAYMENT BECAUSE  *
      * OUTLIER CAP WAS MET BEFORE THIS CLAIM WAS PROCESSED -       *
      * ZERO OUT LINE OUTLIER PAYMENT & REMOVE FROM CLAIM TOTAL     *
      * 8/21/16 -MOVE 2 TO RETURN CODE, IF FLAG = 6 & OUTL PYMT > 0 *
      *-------------------------------------------------------------*
             IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6')
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT
                MOVE 02 TO A-CLM-RTN-CODE.


       17600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *               CAP CMHC TOTAL OUTLIER PAYMENTS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      * FOR CMHC CLAIMS ONLY, DO THE FOLLOWING:                     *
      *                                                             *
      * - DETERMINE IF THE TOTAL CLAIM OUTLIER PAYMENT ELIGIBLE     *
      *   FOR CAPPING IS > $0                                       *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS PAYMENTS INCLUDING THE *
      *   CURRENT CLAIM'S PAYMENTS                                  *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS OUTLIER PAYMENTS       *
      *   INCLUDING THE CURRENT CLAIM'S OUTLIER PAYMENTS            *
      * - CALCULATE THE CURRENT OUTLIER PERCET                      *
      * - IF THE OUTLIER PERCENT EXCEEDS THE CAP:                   *
      *   - SET THE CLAIM OUTLIER TO $0                             *
      *   - SET THE RETURN CODE TO 02                               *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JULY 2017, EFFECTIVE JANUARY 2017                 *
      *                                                             *
      ***************************************************************
       17610-CMHC-OUTL-CAP.
             IF ( (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999') ) AND
                H-CMHC-OUTL-TOTAL > 0

      *-------------------------------------------------------------*
      *            CALCULATE PROVIDER'S TOTAL PAYMENTS              *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-PYMT-TOTAL =  H-CMHC-PYMT-TOTAL +
                        L-PRIOR-PYMT-TOTAL

      *-------------------------------------------------------------*
      *       CALCULATE PROVIDER'S TOTAL OUTLIER PAYMENTS           *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTL-TOTAL =  H-CMHC-OUTL-TOTAL +
                        L-PRIOR-OUTL-TOTAL

      *-------------------------------------------------------------*
      *                 CALCULATE OUTLIER PERCENT                   *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTLIER-PCT ROUNDED =
                   H-CMHC-OUTL-TOTAL / H-CMHC-PYMT-TOTAL

      *-------------------------------------------------------------*
      *                     APPLY OUTLIER CAP                       *
      *-------------------------------------------------------------*
                IF H-CMHC-OUTLIER-PCT > CMHC-OUTL-CAP-PCT
                   MOVE 0 TO H-OUTLIER-PYMT
                   MOVE 02 TO A-CLM-RTN-CODE
                END-IF
             END-IF.

       17610-CMHC-OUTL-CAP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 17550-CALC-RU &        *
      *      17550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES        *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       17655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9021' OR
                                    'P9056' OR
                                    'P9010' OR
                                    'P9016' OR
                                    'P9051' OR
                                    'P9038' OR
                                    'P9058' OR
                                    'P9040' OR
                                    'P9057' OR
                                    'P9054' OR
                                    'P9022' OR
                                    'P9039'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       17655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *        PROCESS COINSURANCE CAP ROLL-UP TABLE RECORDS        *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE BLOOD LINE COINSURANCE WHEN THE PROCEDURE       *
      *  COINSURANCE AMOUNTS PLUS THE BLOOD COINSURANCE AMOUNT(S)   *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       17800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 17810-PROCESS-TYPE1
                   THRU 17810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 17840-PROCESS-TYPE2
                   THRU 17840-PROCESS-TYPE2-EXIT.

       17800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH BLOOD COINSURANCE, DETERMINE THE  *
      *  % OF TOTAL BLOOD COINSURANCE THAT CAN BE PAID IN ADDITION  *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE BLOOD COINSURANCE CAN BE PAID*
      *  WHEN H-RATIO = 1, ALL OF THE BLOOD COINSURANCE CAN BE PAID *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       17810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * BLOOD WAS ADMINISTERED ON THE DAY                           *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & ACTUAL COINSURANCE OF THE             *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-COIN1 (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL BLOOD COIN THAT CAN BE   *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      * CHANGED NATIONAL COINSURANCE TO ACTUAL COINSURANCE FOR      *
      * CY2018                                                      *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-COIN1 (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S BLOOD COIN CAN BE PAID B/C THE PROCEDURE/ *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL BLOOD COINSURANCE CAN BE PAID WITHIN THE    *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       17810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE BLOOD LINE'S NATIONAL COINSURANCE AMOUNT AND    *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       17840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 BLOOD COIN REC HAS SAME DATE OF SERVICE AS   *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE BLOOD COIN RECORD*
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE BLOOD LINE BY  *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD BLOOD COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT   *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       17840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       17900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       17900-END-PRICE-RTN-EXIT.
           EXIT.



      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 18000 FOR CALENDAR YEAR 2019 PROCESSING        **
      **          SERVICE FROM DATES: 1/1/2019 - 12/31/2019           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE IOCE)      *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  7. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  8. CALCULATE SERVICE LINE PAYMENTS                            *
      *  9. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 10. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 11. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 12. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 13. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, AND COMPOSITE *
      *     CHARGES OF APPLICABLE PROCEDURES.                          *
      *     ALL ADJUSTMENTS ARE DONE FOR OUTLIER DETERMINATION ONLY.   *
      * 14. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 15. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR BLOOD LINES; *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE BLOOD LINE'S REIMBURSEMENT                    *
      * 18. ACCUMULATE CLAIM TOTALS                                    *
      * 18. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       18000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY),  *
      *            DETERMINE CLAIM DEVICE CREDIT AMOUNT               *
      *            (CLAIM LEVEL INITIALIZATION)                       *
      *                                                               *
      *****************************************************************
              PERFORM 18100-INIT
                 THRU 18100-INIT-EXIT.

      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - C-APC-CLAIM-FLAG - COMPREHENSIVE APC ON CLAIM - FOR       *
      *     SPECIAL BLOOD DEDUCTIBLE LINE LOGIC                       *
      *                                                               *
      *****************************************************************
              PERFORM 18125-INIT
                 THRU 18125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.



      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH *
      *            RADIOPHARMACEUTICAL OFFSET, CREATE CONTRAST        *
      *            AGENT PROCEDURE TABLE FOR PASS-THROUGH CONTRAST    *
      *            AGENT OFFSET.                                      *
      *            (LOOP THROUGH THE CLAIM LINES)                     *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY TABLES FOR NEW CLAIM                             *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX    W-BLD-MAX    W-CMP-MAX.

              PERFORM 18150-INIT
                 THRU 18150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      *-------------------------------------------------------------*
      * CALCULATE WAGE-ADJUSTED PASS-THROUGH DEVICE OFFSETS         *
      * (VALUE CODES QN, QO & QP; CLAIM LEVEL)                      *
      * NEW FOR CY2016 - 11/13/2015                                 *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QN > 0
                COMPUTE H-QN-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QN * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QN * .40)
             END-IF.

             IF L-PAYER-ONLY-VC-QO > 0
                COMPUTE H-QO-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QO * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QO * .40)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF L-PAYER-ONLY-VC-QP > 0
      *         COMPUTE H-QP-WA-PTD-OFFSET ROUNDED =
      *                 ((L-PAYER-ONLY-VC-QP * .60) * H-WINX) +
      *                 (L-PAYER-ONLY-VC-QP * .40)
      *      END-IF.



      *****************************************************************
      *                                                               *
      *   STEP 4 - INITIALIZE W-DCP-MAX                               *
      *   ------                                                      *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, AND MOVE LINE ITEM         *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 18400-CALCULATE
                 THRU 18400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, AND COMPOSITES, AND CALCULATE  *
      *            OUTLIER PAYMENTS                                   *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 18600-ADJ-CHRG-OUTL
                 THRU 18600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.
              PERFORM 18610-CMHC-OUTL-CAP
                 THRU 18610-CMHC-OUTL-CAP-EXIT.

      *****************************************************************
      *                                                               *
      *   STEP 7 - RECALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS*
      *   ------   FOR STATUS INDICATOR R (BLOOD) LINES WHEN THE DAILY*
      *            INPATIENT DEDUCTIBLE CAP IS EXCEEDED.              *
      *            THE COINSURANCE CAP IS APPLIED USING THE WAGE      *
      *            ADJUSTED NATIONAL COINSURANCE OF EACH DAY'S MOST   *
      *            EXPENSIVE PROCEDURE OR VISIT.                      *
      *            (LOOP THROUGH THE COINSURANCE CAP ROLL-UP TABLE)   *
      *                                                               *
      *****************************************************************
                IF BLOOD-FLAG = 'Y'
                   PERFORM 18800-ADJ-STV-REIM
                      THRU 18800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                END-IF.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 18900-END-PRICE-RTN
                 THRU 18900-END-PRICE-RTN-EXIT.

       18000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY DEDUCTIBLE CAP (H-IP-LIMIT)            *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       18100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE FLAGS AND VARIABLES               *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 11/03/2008 - APC33-FLAG REPLACED BY PHP-APC-FLAG            *
      * 11/12/2008 - BRACHY-APC-FLAG REMOVED, NOT USED FOR CY 2009  *
      * 02/09/2009 - PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG ADDED    *
      * 11/16/2009 - RADIOPH-APC-FLAG REMOVED; PTCA-CLAIM-FLAG,     *
      *              PTCA-LINE FLAG ADDED                           *
      * 02/07/2012 - BILL14X-FLAG REMOVED                           *
      * 11/18/2013 - DEVCR-CLAIM-FLAG ADDED                         *
      * 11/18/2015 - REMOVED APC34-FLAG (MENTAL HEALTH), PTD-FLAG,  *
      *              PTD-LINE-FLAG, PTD-PROC-FLAG, AND              *
      *              C1820-OFFSET-FLAG BECAUSE THEY'RE NOT USED     *
      * 02/09/2016 - ADD LOGIC TO DETERMINE CLAIM'S DEVICE CREDIT   *
      * 02/10/2016 - DEVCR-CLAIM-FLAG REMOVED (NO LONGER USED)      *
      * 10/26/2016 - PHP-HCPCS-FLAG, MH-HCPCS-FLAG,                 *
      *              PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG,         *
      *              PTCA-CLAIM-FLAG, PTCA-LINE-FLAG REMOVED        *
      *              (NO LONGER USED)                               *
      *                                                             *
      *-------------------------------------------------------------*
             MOVE 'N'   TO BLOOD-FLAG
                           ST0-FLAG
                           N-FLAG
                           BLD-DEDUC-HCPCS-FLAG
                           C-APC-CLAIM-FLAG
                           PKG-BLD-DED-LINE-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO  TO A-OUTLIER-PYMT
                           A-TOTAL-CLM-DEDUCT
                           A-TOT-CLM-CHRG
                           A-TOT-CLM-PYMT
                           A-BLOOD-DEDUCT-DUE
                           A-BLOOD-PINTS-USED
                           A-WINX
                           W-LNC-MAX
                           A-DEVICE-CREDIT-QD.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
      *-------------------------------------------------------------*
      * INITIATILIZE WORKING STORAGE DATES - 10-23-2014             *
      *-------------------------------------------------------------*
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-BEGIN-YYYY.
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-END-YYYY.

      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 18100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 18100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 18100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION18 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE THE TOTAL DEVICE CREDIT AMOUNT TO BE DEDUCTED     *
      * FROM THE CLAIM - USE THE LESSER OF THE AMOUNT IN            *
      * VALUE CODE FD AND THE CAP AMOUNT IN VALUE CODE QU           *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QU > 0 AND
                L-DEVICE-CREDIT > 0
                IF L-PAYER-ONLY-VC-QU < L-DEVICE-CREDIT
                   MOVE L-PAYER-ONLY-VC-QU TO H-CLAIM-DEVCR-AMT
                ELSE
                   MOVE L-DEVICE-CREDIT TO H-CLAIM-DEVCR-AMT
                END-IF
             END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = 'D'
                      MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
                   ELSE
      *-------------------------------------------------------------*
      *   USE SPECIAL WAGE INDEX WHEN INDICATED                     *
      *   (PSF RECORD EFFECTIVE DATE MUST BE WITHIN THE CLAIM'S CY) *
      *   ADDED 10-23-2014 FOR CY 2015                              *
      *-------------------------------------------------------------*
                      IF (L-PSF-SPEC-PYMT-IND = '1' OR '2') AND
                         (L-PSF-EFFDT >= W-CY-BEGIN-DATE AND
                          L-PSF-EFFDT <= W-CY-END-DATE)
                          MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                          MOVE L-PSF-SPEC-WGIDX TO H-WINX
                          MOVE 1364 TO H-IP-LIMIT
                          GO TO 18100-INIT-EXIT
                      ELSE
                         MOVE  52  TO A-CLM-RTN-CODE
                         GO TO 18100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 18100-INIT-EXIT.

             MOVE 1364 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      * APPLY WAGE INDEX FLOOR POLICY                               *
      * (USE HIGHER OF CBSA WAGE INDEX AND STATE RURAL WAGE INDEX)  *
      *-------------------------------------------------------------*
      * 10-23-2014 - NEW FLOOR LOGIC FOR CY 2015                    *
      * 10-28-2015 - NEW STATE CODES ADDED FOR APRIL 2016           *
      *-------------------------------------------------------------*

      *-------------------------------------------------------------*
      * >FIRST, CONFIRM FLOOR SWITCH IS SET                         *
      *-------------------------------------------------------------*
             SET W-FLOOR-LOOKUP TO TRUE.

      *-------------------------------------------------------------*
      * >GET PROVIDER'S STATE CODE FOR RURAL FLOOR WAGE INDEX       *
      *  LOOK-UP (NEW FOR JULY 2016)                                *
      *-------------------------------------------------------------*
             MOVE L-PSF-STATE-CODE TO W-PSF-PROV-ST.

      *-------------------------------------------------------------*
      * >NOW, CALL WAGE INDEX LOOKUP AND LOOK FOR THE STATE FLOOR.  *
      *  STORE PSF-CBSA IN A-CBSA (IT GETS MOVED THERE IN THE NEXT  *
      *  STEP ANYWAY). THIS FREES H-PSF-CSBA FOR THE FLOOR SEARCH   *
      *  MOVE THREE SPACES + STATE CODE TO H-PSF-CBSA               *
      *  STORE RESULT IN H-WINX.                                    *
      *  MOVE A-CBSA BACK TO H-PSF-CBSA FOR CLEANUP                 *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             STRING '   ' DELIMITED BY SIZE
                   W-PSF-PROV-ST DELIMITED BY SIZE
                   INTO H-PSF-CBSA.
             PERFORM 18200-CALC-WAGEINDX
                THRU 18200-CALC-WAGEINDX-EXIT.
             MOVE A-CBSA TO H-PSF-CBSA.

      *-------------------------------------------------------------*
      * >GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN   *
      *  BY THE PSF SPECIAL WAGE INDEX VALUE)                       *
      *                                                             *
      *   NOTE: IF PSF SPECIAL WAGE INDEX VALUE USED,               *
      *         15100-INIT-EXIT WILL BE CALLED ABOVE - THIS CODE    *
      *         WILL NEVER BE REACHED. THEREFORE CHECKING FOR A 0   *
      *         VALUE SHOULD BE UNNECESSARY.                        *
      * >SET WAGE INDEX LOOKUP FLAG (FLOOR FLAG = 'N')              *
      *-------------------------------------------------------------*
             SET W-WINX-LOOKUP TO TRUE.

                PERFORM 18200-CALC-WAGEINDX
                   THRU 18200-CALC-WAGEINDX-EXIT.

      ***************************************************************
      * DETERMINE OUTMIGRATION ADJUSTMENT BASED ON COUNTY CODE, IF  *
      * WAGE INDEX CBSA FIELD AND STANDARDIZED AMOUNT CBSA FIELD    *
      * BLANK, AND SPECIAL PYMT INDICATOR ARE BLANK APPLY ADJUSTMENT*
      * IF NOT- DONT APPLY                                          *
      ***************************************************************
             IF ( L-PSF-WI-CBSA = '     ' OR
                  L-PSF-WI-CBSA = '00000') AND
                ( L-PSF-PYMT-CBSA = '     ' OR
                  L-PSF-PYMT-CBSA = '00000') AND
                  L-PSF-SPEC-PYMT-IND = ' '

      ***************************************************************
      * INITIALIZE OUTM-IND (INDICATOR) - CLEAR VARIABLE            *
      * SEARCH FOR OUTMIGRATION COUNTY CODE MATCH WITHIN TABLE,     *
      * AT FIRST OCCURENCE USE (OUTM-IDX2) AS POINTER (REFERENCE)   *
      * FOR (OUTM-IDX) INITIAL LINE LOCATION MATCH                  *
      ***************************************************************

                INITIALIZE OUTM-IND
                SET OUTM-IDX TO 1
                SEARCH OUTM-TAB VARYING OUTM-IDX
                   AT END
                      MOVE 0 TO OUTM-IND

                   WHEN OUTM-CNTY(OUTM-IDX) =
                    L-PSF-COUNTY-CODE
                    SET OUTM-IDX2 TO OUTM-IDX
                    MOVE 1 TO OUTM-IND
             END-IF.

      ***************************************************************
      * WHEN OUTM-IND = 1, THIS MEANS COUNTY CODE MATCH WAS FOUND   *
      * LOOP THRU EACH LINE THEN PERFORM PARAGRAPH UNTIL CONDITION  *
      * (IF-STATEMENT) IS TRUE, THE COUNTY CODES NO LONGER MATCH    *
      * ON LAST LINE OF DATE MATCH FOR COUNTY CODE, MOVE            *
      * OUTMIGRATION ADJUSTMENT, TO HLD-OUTM-ADJ VARIABLE           *
      * FOR COMPUTATION                                             *
      ***************************************************************
               IF OUTM-IND = 1
                 PERFORM 18120-GET-OUTM-ADJ THRU
                           18120-GET-OUTM-ADJ-EXIT
                  VARYING OUTM-IDX2 FROM OUTM-IDX BY 1 UNTIL
                OUTM-CNTY(OUTM-IDX2) NOT = L-PSF-COUNTY-CODE
      ***************************************************************
      * FOR FYS 2018 AND AFTER, APPLY THE OUTMIGRATION ADJUSTMENT   *
      * ADD OUT MIGRATION ADJUST TO WAGE INDEX FOR NEW H-WINX       *
      ***************************************************************
                COMPUTE H-WINX = H-WINX + HLD-OUTM-ADJ
               END-IF.


       18100-INIT-EXIT.
           EXIT.

       18120-GET-OUTM-ADJ.
             IF OUTM-EFF-DATE(OUTM-IDX2) <= L-SERVICE-FROM-DATE AND
                OUTM-EFF-DATE(OUTM-IDX2) >= W-CY-BEGIN-DATE AND
                OUTM-EFF-DATE(OUTM-IDX2) <= W-CY-END-DATE
                 MOVE OUTM-ADJ-FACT(OUTM-IDX2) TO HLD-OUTM-ADJ
             END-IF.
       18120-GET-OUTM-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND APC / HCPCS/ FLAGS  *
      *                                                             *
      *  - SET FLAG IF APC = 5851/5852/5861/5862 (PARTIAL HOSP.)    *
      *  - SET FLAG IF PASS-THROUGH RADIOPHARMS(S) ON CLAIM         *
      *    (NEW FOR APRIL CY 2009 - ADDED 02/10/2009)               *
      *  - SET FLAG IF PASS-THROUGH CONTRAST AGENT(S) ON CLAIM      *
      *    (NEW FOR JANUARY CY 2010 - ADDED 11/15/2009)             *
      *  - SET FLAG IF CLAIM IS ELIGIBLE FOR DEVICE CREDIT          *
      *    (NEW FOR JANUARY CY 2014)                                *
      *  - SET FLAG IF CLAIM HAS A COMPREHENSIVE APC (C-APC) LINE   *
      *    (NEW FOR JULY 2016)                                      *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION HCPCS FROM     *
      *              0033 TO 0172 & 0173 FOR CY 2009                *
      *                                                             *
      * 11/12/2008 - HCPCS C1820 EXPIRED FROM PASS-THROUGH STATUS   *
      *              DECEMBER 2007, OFFSET FLAG LOGIC DISABLED      *
      *                                                             *
      * 08/02/2010 - ADDED LOGIC TO SET PASS-THOUGH DEVICE FLAG FOR *
      *              DEVICE OFFSETS AND POPULATE THE CORRESPONDING  *
      *              TABLE                                          *
      *                                                             *
      * 11/15/2010 - ADDED APCS 0175 & 0176 TO LIST OF PHP APCS     *
      *                                                             *
      * 11/18/2013 - ADDED LOGIC TO SET DEVICE CREDIT CLAIM FLAG    *
      *                                                             *
      * 11/17/2015 - REMOVED LOGIC TO SET FLAGS FOR PASS-THROUGH    *
      *              DEVICES (FOR OUTLIER & OFFSET LOGIC)           *
      *            - UPDATED PHP APCS FOR 2016                      *
      *            - REMOVED APC34-FLAG (MENTAL HEALTH) - NOT USED  *
      *            - REMOVED APC 0339 UNITS OVERRIDE                *
      *                                                             *
      * 05/09/2016 - ADDED LOGIC TO SET COMPREHENSIVE APC CLAIM FLAG*
      * 10/26/2016 - REMOVED PHP APC CHECK, PT RADIOPHARM CHECK,    *
      *              AND PT CONTRAST AGENT CHECK                    *
      *                                                             *
      ***************************************************************
       18125-INIT.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A COMPREHENSIVE APC     *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = 'J1' OR
                OPPS-SRVC-IND (LN-SUB) = 'J2'
                MOVE 'Y' TO C-APC-CLAIM-FLAG
             END-IF.


       18125-INIT-EXIT.
           EXIT.




      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0, 6, 7, 8,    *
      *                9, OR 'A' (PAYMENT METHOD FLAG)              *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       18150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 18250-CALC-DISCOUNT
                THRU 18250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 18150-INIT-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 10/26/2016 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG REMOVED         *
      *-------------------------------------------------------------*
             MOVE 'N' TO PKG-BLD-DED-LINE-FLAG.


      ***************************************************************
      *   IDENTIFY LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE ON       *
      *   A CLAIM WITH A COMPREHENSIVE APC; TREAT AS PACKAGED LINE  *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      ***************************************************************
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             END-IF.


      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR ' L' OR
                ' N' OR ' P' OR ' R' OR ' S' OR ' T' OR ' U' OR
                ' V' OR ' X' OR ' W' OR ' Y' OR ' Z' OR ' M' OR
                'J1' OR 'J2')
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 18150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' K' OR ' L' OR ' W' OR
                ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 18150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      * 10/26/2016- REMOVED PHP/MENTAL HEALTH CODE LISTS            *
      * 01/19/2017- ADDED '3' INTO LOGIC, FOR FISS INFORMATINAL USE *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF  OPPS-LITEM-DR-FLAG (LN-SUB) = ('0' OR '3') OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                       OPPS-LITEM-ACT-FLAG (LN-SUB) = '1'



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      * 11/03/2008 - REMOVED PAFS 91 - 99 FOR COMPOSITES FOR CY 2009*
      * 04/11/2011 - ADDED ' 9' & '10' AS VALID PAFS FOR CY 2011    *
      * 12/18/2014 - ADDED '11' FOR CY 2015                         *
      * 11/10/2015 - ADDED '12' - '14' FOR CY 2016                  *
      * 02/05/2016 - ADDED '16' - '20' FOR CY 2016                  *
      *              (PAF '15' RESERVED FOR FUTURE USE)             *
      * 08/11/2016 - ADDED '21' FOR CY 2016                         *
      * 10/16/2017 - ADDED '22' FOR CY 2018                         *
      * 10/23/2018 - ADDED '23' FOR CY 2019                         *
      * 10/23/2018 - ADDED '24' FOR CY 2019                         *
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8' OR ' 9' OR '10' OR '11'
                             OR '12' OR '13' OR '14'         OR '16'
                             OR '17' OR '18' OR '19' OR '20' OR '21'
                             OR '22' OR '23' OR '24'


      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *                                                             *
      *   ** SITE OF SERVICE FLAG = PAYMENT METHOD FLAG IN OCE **   *
      *                                                             *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', PHP APC IS ON THE CURRENT LINE       *
      *-------------------------------------------------------------*
      * 11/06/2007 - CHANGED PHP HEALTH CODES LISTED FROM           *
      *              APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008   *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION APC FROM       *
      *              0033 TO 0172 & 0173 FOR CY 2009, FLAG CHANGED  *
      *              FROM APC33-FLAG TO PHP-APC-FLAG                *
      * 10/19/2016 - ADDED VALUES '7' AND '8' FOR SECTION 603       *
      *              SERVICE LINES (MODIFIER 'PN')                  *
      * 10/26/2016 - REMOVED PHP SPECIFIC LOGIC                     *
      * 03/02/2017 - ADD PMF FLAG '9' VALUE TO VALID LIST           *
      * 11/05/2018 - ADD PMF FLAG 'A' VALUE TO VALID LIST           *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '9') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'A')



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE ALL PACKAGED COMPOSITE LINES                      *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *   11/12/2008 - CHANGED LOGIC THAT EXCLUDES ALL COMPOSITE    *
      *                LINES & MENTAL HEALTH PKG LINES TO USE THE   *
      *                COMPOSITE ADJUSTMENT FLAG INSTEAD OF PAYMENT *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *   05/09/2016 - ADDED LOGIC TO ENSURE BLOOD DEDUCTIBLE LINES *
      *                ON CLAIMS WITH A COMPREHENSIVE APC ARE       *
      *                INCLUDED                                     *
      *-------------------------------------------------------------*
                IF ( (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                     (OPPS-COMP-ADJ-FLAG (LN-SUB) = '00') ) OR
                     PKG-BLD-DED-LINE
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED REVENUE CODE 39X BLOOD LINE CHARGES   *
      *   (BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC)      *
      *   WHEN BILLED ON CLAIM WITH A COMPREHENSIVE APC TO          *
      *   DETERMINE THE PORTION OF THE BLOOD APC PAYMENT TO BE      *
      *   DISTRIBUTED TO THE BLOOD PRODUCT (PAF = 5) LINE FOR THE   *
      *   BLOOD DEDUCTIBLE CALCULATION                              *
      *-------------------------------------------------------------*
      *   05/16/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' N' AND
               (OPPS-LITEM-RVCD (LN-SUB) = '0390' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0392' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0399')
                  COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB) +
                                          H-TOT-38X-39X
             END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME (PACKAGED) COMPOSITE APC CHARGES     *
      *   FOR EACH COMPOSITE APC BY THE COMPOSITE ADJUSTMENT FLAG   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2007 - LOGIC REVISED FOR CY 2009 TO IDENTIFY ALL    *
      *                COMPOSITE LINES USING THE COMPOSITE          *
      *                ADJUSTMENT FLAG INSTEAD OF PAYMENT           *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *                (INCLUDES PROCESSING FOR MENTAL HEALTH       *
      *                 COMPOSITES)                                 *
      *-------------------------------------------------------------*
                IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "00" AND
                   OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "  " AND
                   OPPS-SRVC-IND (LN-SUB) = ' N'
                      PERFORM 18170-COMPOSITES
                         THRU 18170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   SET RETURN CODE & EXIT WHEN PACKAGED LINE/LINE APC = 0000 *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 18150-INIT-EXIT
                END-IF


      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 18150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 18175-APC-LOOKUP

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT METHOD FLAG = '8' (603 SV)*
      *   SET THE COINSURANCE AND REIMBURSEMENT TO PFS RATES        *
      *   10/16/2017 - NEW FOR CY 2018; 40% REDUCTION               *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * PFS-REDUCT-2018
                      END-IF

                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                         COMPUTE H-MIN-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         COMPUTE H-NAT-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         MOVE    PFS-REIM-RATE TO H-PPCT
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT METHOD FLAG = 'A'         *
      *   11/05/2018 - NEW FOR CY 2019;PAY 70% OF APC RATE          *
      *   10/22/2019 - AMERICAN HOSPITAL ASSOCIATION ET AL V. AZAR  *
      *    LAWSUIT    REMOVE PMF = 'A' LOGIC EFF. 10/22/2019        *
      *   11/12/2019 - NEW FOR CY 2020; PAYS 40% OF APC RATE        *
      *   08/02/2021 - REACTIVATED FOR 2019- PAY 70% OF APC RATE    *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = 'A'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * PMF-A-REDUCT-2019
                     END-IF


      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '14' (CT SCAN) *
      *   11/10/2015 - NEW FOR CY 2016; 5% REDUCTION                *
      *   07/15/2016 - NEW FOR CY 2017; 15% REDUCTION               *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '14'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * CT-REDUCT-2017
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '21' OR '23'   *
      *   (X-RAY SV)                                                *
      *   08/11/2016 - NEW FOR CY 2017; 20% REDUCTION FOR FILM XRAY *
      *   10/23/2018 - ADD PAF 23 FOR CY 2019                       *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ('21' OR '23')
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * XRAY-FILM-REDUCT-2017
                      END-IF


      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '22' OR '24'   *
      *   (X-RAY SV)                                                *
      *   07/18/2017 - NEW FOR CY 2018; 07% REDUCTION FOR CRT XRAY  *
      *   10/23/2018 - ADD PAF 24 FOR CY 2019                       *
      *** REDUCTION RATE WILL CHANGE TO 10% FOR CY 2023         *****
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ('22' OR '24')
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * XRAY-CRT-REDUCT-2018
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT BY REDUCED UPDATE RATIO WHEN APPROPRIATE   *
      *   11/13/2009 - NEW FOR CY 2009 (QUALITY)                    *
      *   10/19/2016 - EXCLUDE 603 SERVICES FROM QUALITY REDUCTION  *
      *                (PMT METHOD FLAG = 7 OR 8)                   *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8'
                         PERFORM 18180-REDUCE-APC-PYMT
                            THRU 18180-REDUCE-APC-PYMT-EXIT
                      END-IF



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 18150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 18150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 18150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 18150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 18150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 18150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF LINES ELIGIBLE FOR DEVICE CREDIT *
      * WHEN THE CLAIM'S TOTAL DEVICE CREDIT IS > $0 AND THE LINE   *
      * HAS PAYMENT ADJUSTMENT FLAG '17'                            *
      * - REVISED DEVICE CREDIT LOGIC FOR APRIL 2016                *
      ***************************************************************
             IF H-CLAIM-DEVCR-AMT > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17'
                COMPUTE H-TOT-DEVCR-PYMTS =
                        H-TOT-DEVCR-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF TERMINATED PROCEDURE LINES       *
      * ELIGIBLE FOR DEVICE OFFSET WHEN PAYER ONLY VALUE CODE QQ    *
      * IS > $0 AND THE LINE HAS PAYMENT ADJUSTMENT FLAG '16'       *
      * (LINE MODIFIER IS 73)                                       *
      * - IMPLEMENTED IN APRIL 2016                                 *
      ***************************************************************
             IF L-PAYER-ONLY-VC-QQ > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16'
                COMPUTE H-TOT-TPDO-PYMTS =
                        H-TOT-TPDO-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE LINE CHARGES OF PASS-THROUGH DEVICE LINES        *
      * ASSOCIATED WITH PAYER ONLY VALUE CODES QN AND QO            *
      * - LINES WITH PAF '12' RECEIVE OFFSET IN VALUE CODE QN       *
      * - LINES WITH PAF '13' RECEIVE OFFSET IN VALUE CODE QO       *
      * - LINES WITH PAF '15' RECEIVE OFFSET IN VALUE CODE QP       *
      * NEW FOR CY2016 - 11/13/2015                                 *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
                COMPUTE H-QN-TOT-PTD-CHARGES =
                        H-QN-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
                COMPUTE H-QO-TOT-PTD-CHARGES =
                        H-QO-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *         COMPUTE H-QP-TOT-PTD-CHARGES =
      *                 H-QP-TOT-PTD-CHARGES +
      *                 OPPS-SUB-CHRG (LN-SUB)
      *      END-IF.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                PERFORM 18300-COIN-DEDUCT
                   THRU 18300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2009.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                SET W19BD-INDX TO 1
                SEARCH W19BD-ENTRY VARYING W19BD-INDX
                   AT END
                      GO TO 18150-INIT-EXIT
                   WHEN W-2019-BLOOD-HCPCS (W19BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-2019-BLOOD-RANK (W19BD-INDX) TO H-BLOOD-RANK
                     MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                     PERFORM 18375-BLOOD-DEDUCT
                        THRU 18375-BLOOD-DEDUCT-EXIT
                    END-IF.

       18150-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH COMPOSITE          *
      *  ADJUSTMENT FLAG NOT = '00' & POPULATE COMPOSITE APC TABLE  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY COMPOSITE ADJUSTMENT FLAG (CAF) -   *
      *    LOWEST TO HIGHEST FLAG VALUE (01 - NN)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH CAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *  11/12/2008 - LOGIC REVISED FOR CY 2009 TO USE THE          *
      *               COMPOSITE ADJUSTMENT FLAG INSTEAD OF THE      *
      *               PAYMENT ADJUSTMENT FLAG, VARIABLE H-CMP-CAF   *
      *               HOLDS COMPOSITE ADJUSTMENT FLAG, VARIABLE     *
      *               W-CMP-PAF RETAINED AND NOW HOLDS THE CAF      *
      *               (RETAINED TO CONTINUE USE OF EXISTING TABLE)  *
      *                                                             *
      ***************************************************************
       18170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S COMPOSITE ADJUSTMENT FLAG FOR TABLE SEARCH   *
      *-------------------------------------------------------------*
             MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE CAF         *
      *-------------------------------------------------------------*
                PERFORM 18171-SEARCH-CAF
                   THRU 18171-SEARCH-CAF-EXIT.

       18170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       18171-SEARCH-CAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS NOT      *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 18172-ADD-ENTRY
                      THRU 18172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS ALREADY  *
      * IN THE TABLE, UPDATE THE ENTRY                              *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                   PERFORM 18173-UPDATE-ENTRY
                      THRU 18173-UPDATE-ENTRY-EXIT.

       18171-SEARCH-CAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       18172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS COMPOSITE ADJUSTMENT FLAG (CAF) - LOWEST TO HIGHEST CAF *
      *-------------------------------------------------------------*
             PERFORM 18174-STAGE-CMP-ENTRY
                THRU 18174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-CAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-CAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       18172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * COMPOSITE ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE       *
      *                                                             *
      ***************************************************************
       18173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE CAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       18173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER CAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       18174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       18174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       18175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 18175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       18175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      REDUCE APC PAYMENT OF LINES FROM PROVIDERS WITH A      *
      *      SPACE IN THE QUALITY INDICATOR FIELD OF THE OPSF       *
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      *  11/16/2010 - ADDED SI = U (BRACHY) TO LOGIC                *
      *                                                             *
      ***************************************************************
       18180-REDUCE-APC-PYMT.

      *-------------------------------------------------------------*
      *  SPECIFY LINES ELIGIBLE FOR REDUCTION                       *
      *  11/13/2019- QUALITY ADJUSTMENT EXCLUSION FOR NEW TECHNOLOGY*
      *  CATEGORY APC RANGES:                                       *
      *             - 1575-1599 (EFF. 1/1/2016)                     *
      *             - 1901-1906 (EFF. 1/1/2017)                     *
      *             - 1907-1908 (EFF. 1/1/2018)                     *
      *-------------------------------------------------------------*
             IF ( L-PSF-HOSP-QUAL-IND = ' ' )  AND

                (  (OPPS-SRVC-IND (LN-SUB) = ' P')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' R')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' S' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01491' AND
                           OPPS-GRP (LN-SUB) <= '01537') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01575' AND
                           OPPS-GRP (LN-SUB) <= '01585') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01908'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' T' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01539' AND
                           OPPS-GRP (LN-SUB) <= '01574') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01589' AND
                           OPPS-GRP (LN-SUB) <= '01599') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01908'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' U')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' V')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' X')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J1')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J2')  ) THEN

                COMPUTE H-APC-PYMT ROUNDED = H-APC-PYMT * 0.980
                MOVE 11 TO A-RETURN-CODE (LN-SUB)

             END-IF.


       18180-REDUCE-APC-PYMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       18200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   IF W-WINX-LOOKUP
                      MOVE  50  TO A-CLM-RTN-CODE
                   END-IF
                   GO TO 18200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA

      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 18210-WAGE-LOOKUP.

      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0 OR NOT NUMERIC             *
      *   *AND* NOT ON RURAL FLOOR LOOKUP                           *
      ***************************************************************

             IF (H-WINX = 0 OR H-WINX NOT NUMERIC) AND
                 W-WINX-LOOKUP THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       18200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       18210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE MEETS THE CRITERIA:       *
      *  - MUST NOT BE AFTER THE LATEST WAGE INDEX EFFECTIVE DATE   *
      *    THAT CAN BE USED BY THE CLAIM                            *
      *  - EXCEPT FOR INDIAN HEALTH PROVIDERS (CBSAS 98 AND 99),    *
      *    MUST BE WITHIN THE CLAIM'S CALENDAR YEAR                 *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD / LATEST         *
      *   EFFECTIVE DATE FOR THE CBSA)                              *
      ***************************************************************
             MOVE WCW-DTCD (W-SUB3) TO W-WCW-DTCD.

             IF W-WCW-DTCD NOT > WCD-DTCD (WCD-SUB) AND

                ( (WCD-DATE (W-WCW-DTCD) >= W-CY-BEGIN-DATE AND
                   WCD-DATE (W-WCW-DTCD) <= W-CY-END-DATE AND
                   H-PSF-CBSA NOT = '   98' AND
                   H-PSF-CBSA NOT = '   99') OR

                  (H-PSF-CBSA = '   98' OR
                   H-PSF-CBSA = '   99') )

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *   *ONLY VALID FOR WAGE INDEX LOOKUP, NOT RURAL FLOOR*       *
      *   IF WAGE INDEX > FLOOR, OVERWRITE H-WINX                   *
      *-------------------------------------------------------------*
                IF L-PSF-SPEC-PYMT-IND = 'Y' AND W-WINX-LOOKUP THEN
                   IF WCW-WINX2 (W-SUB3) > H-WINX THEN
                      MOVE WCW-WINX2 (W-SUB3) TO H-WINX
                   END-IF
      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *   IF WAGE INDEX > FLOOR OR LOOKING UP RURAL FLOOR, STORE    *
      *   RESULT IN H-WINX.                                         *
      *-------------------------------------------------------------*
                ELSE
                   IF (WCW-WINX1 (W-SUB3) > H-WINX OR W-FLOOR-LOOKUP)
                      MOVE WCW-WINX1 (W-SUB3) TO H-WINX
                   END-IF
                END-IF


      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE DID NOT MEET THE CRITERIA *
      *  - AFTER THE LATEST EFFECTIVE DATE THE CLAIM CAN USE -OR-   *
      *  - NOT WITHIN THE CLAIM'S CALENDAR YEAR AND NOT IN CBSA     *
      *    98 OR 99                                                 *
      *  GO TO THE PRIOR RECORD FOR THIS CBSA WITH AN EARLIER DATE  *
      *  IN THE CBSA WAGE INDEX TABLE.                              *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *  AGAIN AND REPEAT THE PROCESS
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 18210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      * >10-28-2014 ONLY VALID FOR WAGE INDEX PASS, NOT RURAL FLOOR *
      *-------------------------------------------------------------*
                ELSE

                   IF W-WINX-LOOKUP
                      MOVE 0 TO H-WINX
                END-IF
             END-IF.

       18210-WAGE-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       18250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 18250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       18250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       18300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 18350-STAGE-ENTRY
                THRU 18350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX      TO W-WINX (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       18300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       18350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       18350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       18375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 18385-STAGE-ENTRY
                THRU 18385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX     TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       18375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       18385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       18385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PAYMENTS, DEDUCTIBLES, REIM., & COINSURANCE,*
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       18400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 18400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 18550-CALC-STANDARD
                   THRU 18550-CALC-STANDARD-EXIT
             ELSE
                GO TO 18400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRUG COINSURANCE TABLE FOR LATER PROCESSING        *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET BLOOD-FLAG WHEN SERVICE INDICATOR = R (BLOOD)        *
      *  - EXCLUDE PACKAGED BLOOD DEDUCTIBLE LINES & SECTION 603    *
      *    SERVICE LINES                                            *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30 AND
                NOT PKG-BLD-DED-LINE AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                PERFORM 18450-ADJ-PROC-COIN
                   THRU 18450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 18500-ADJ-CHRGS
                THRU 18500-ADJ-CHRGS-EXIT.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

                COMPUTE A-DEVICE-CREDIT-QD =
                        A-DEVICE-CREDIT-QD + H-LINE-DEVCR-AMT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 15840-PROCESS-TYPE2     *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)

               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       18400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      POPULATE COINSURANCE CAP ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: BLOOD LINE                              *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY BLOOD LINE         *
      *                                                             *
      * COINSURANCE RECORD COMBINATIONS:                            *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       BLOOD ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT   *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO BLOOD ADMINISTERED ON THE   *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH BLOOD ADMINISTERED ON THE      *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = R =>               *
      *       BLOOD ADMINSTERED ON THE DATE OF SERVICE              *
      *                                                             *
      ***************************************************************
       18450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                PERFORM 18455-SEARCH-KEY
                   THRU 18455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = R LINES (BLOOD)                                *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET BLOOD-FLAG TO INDICATE BLOOD LINE                       *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO BLOOD-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                   PERFORM 18455-SEARCH-KEY
                      THRU 18455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY BLOOD LINE)*
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = R       *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW BLOOD COINSURANCE ENTRY             *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 18475-STAGE-DCP-ENTRY
                      THRU 18475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, BLOOD                                        *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       18450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COINSURANCE CAP ROLL-UP TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       18455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH COINSURANCE CAP TABLE STARTING AT ENTRY #1           *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 18460-ADD-ENTRY
                      THRU 18460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 18465-UPDATE-ENTRY
                      THRU 18465-UPDATE-ENTRY-EXIT.

       18455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE COINSURANCE TABLE                                       *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       18460-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COINSURANCE CAP TABLE ENTRY         *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 18475-STAGE-DCP-ENTRY
                THRU 18475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, BLOOD                                        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       18460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COINSURANCE RECORD WITH THE SAME        *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       18465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR BLOOD LINES - ACCUMULATE DAY'S TOTAL BLOOD COIN DUE     *
      * -REMOVE ' G' & ' K'                                         *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A BLOOD LINE, UPDATE THE RECORD   *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 18485-REPLACE-TYPE1
                     THRU 18485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 18480-RANK-COIN
                     THRU 18480-RANK-COIN-EXIT.

       18465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COINSURANCE RECORD WITH A HIGHER          *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       18475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       18475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST ACTUAL     *
      * COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE           *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *  CHANGED TO ACTUAL FROM NATIONAL COINSURANCE FOR 2018       *
      ***************************************************************
       18480-RANK-COIN.

             IF H-NEW-COIN > W-DCP-COIN1 (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       18480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = R        *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = BLOOD LINE NEW COINSURANCE AMOUNT(S)              *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       18485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       18485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 15600-ADJ-CHRG-OUTL.)                     *
      *                                                             *
      ***************************************************************
       18500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
      * 12/18/2009 - ADD SIS R & U, WHICH ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P' OR ' R' OR ' U' OR 'J1' OR 'J2')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                AND NOT PKG-BLD-DED-LINE
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       18500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    & TAKE PT DEVICE OFFSET WHEN APPLICABLE                  *
      * 5. CALCULATE AND APPLY DEVICE CREDIT                        *
      *                                                             *
      ***************************************************************
       18550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 18655-SET-BD-HCPCS-FLAG
                THRU 18655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      *   FLAG LINE IF ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND CLAIM  *
      *   HAS A COMPREHENSIVE APC; TREAT AS PACKAGED LINE           *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             ELSE
                  MOVE 'N' TO PKG-BLD-DED-LINE-FLAG
             END-IF.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).


      ***************************************************************
      * CALCULATE DEVICE CREDIT FOR ELIGIBLE LINE(S)                *
      *-------------------------------------------------------------*
      * 02/09/2016- REVISED LOGIC IMPLEMENTED IN APRIL 2016         *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-CLAIM-DEVCR-AMT > 0 AND
                H-TOT-DEVCR-PYMTS > 0
                PERFORM 18550-DEVICE-CREDIT
                   THRU 18550-DEVICE-CREDIT-EXIT.


      ***************************************************************
      * CALCULATE DEVICE OFFSET FOR ELIGIBLE TERMINATED PROCEDURE   *
      * LINES AND REDUCE THE APC PAYMENT BY THE DEVICE OFFSET AMOUNT*
      *-------------------------------------------------------------*
      * 02/09/2016- NEW LOGIC IMPLEMENTED IN APRIL 2016             *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16' AND
                L-PAYER-ONLY-VC-QQ > 0 AND
                H-TOT-TPDO-PYMTS > 0
                PERFORM 18550-TERM-PROC-DEV-OFF
                   THRU 18550-TERM-PROC-DEV-OFF-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, X, J1, OR J2 LINES   *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      * 10/26/2016 - STOPPED PERFORMING PHP OUTLIER CAPPING LOGIC   *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X' OR
                 'J1' OR 'J2') THEN
                  PERFORM 18550-SCH-ADJ
                     THRU 18550-SCH-ADJ-EXIT
                  PERFORM 18560-CALC-BENE-DEDUCT
                     THRU 18560-CALC-BENE-DEDUCT-EXIT


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (PT DEVICE) LINES, PAYMENT IND.*
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      *-------------------------------------------------------------*
      * 01/01/2009 - BRACHYTHERAPY SERVICES ADDED FOR CY 2009       *
      * 11/15/2009 - BRACHYTHERAPY SERVICES (SI=U) REMOVED CY 2010  *
      *            - THERAPEUTIC RADIOPHARMS' SI NOT 'H' FOR CY2010 *
      * 08/11/2010 - NEW PASS-THROUGH DEVICE OFFSET LOGIC ADDED IN  *
      *              PARAGRAPH 10555-CALC-H-STANDARD                *
      * 11/16/2015 - REVISED PT-DEVICE LOGIC: 15555-CALC-H-STANDARD *
      ***************************************************************
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' H') THEN
                 IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                       OPPS-PYMT-IND (LN-SUB) = ' 6')
                   PERFORM 18555-CALC-H-STANDARD
                      THRU 18555-CALC-H-STANDARD-EXIT
                   PERFORM 18560-CALC-BENE-DEDUCT
                      THRU 18560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 18550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = R & U LINES; THE PMT. IND.       *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      * 11/15/2009 - ADDED BRACHYTHERAPY SERVICES (SI=U) FOR CY2010 *
      *              THERAPEUTIC RADIOPHARMS' SI=K FOR CY 2010      *
      * 11/16/2009 - ADD LOGIC TO ADJUST PT CONTRAST AGENT HCPCS    *
      *              LINE PAYMENT BY OFFSET                         *
      * 05/10/2016 - CALCULATE BLOOD DEDUCTIBLE & LINE PAYMENT FOR  *
      *              BLOOD DEDUCTIBLE LINES ON COMPREHEMSIVE APC    *
      *              CLAIMS (THESE LINES WERE PREVIOUSLY PACKAGED)  *
      *            - ADD LOGIC TO EXEMPT BLOOD DEDUCTIBLE LINES ON  *
      *              COMPREHENSIVE APC CLAIMS FROM REIM, COIN, &    *
      *              NON-BLOOD DEDUCTIBLE CALCS.                    *
      * 10/21/2016 - NO LONGER CALCULATE PAYMENT FOR SI G & K LINES *
      *              (DRUGS) IN PRICER; NOW CALCULATED IN FISS      *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 18550-CALC-RU
                         THRU 18550-CALC-RU-EXIT

                      IF PKG-BLD-DED-LINE
                         NEXT SENTENCE
                      END-IF

                      PERFORM 18560-CALC-BENE-DEDUCT
                         THRU 18560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 18550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      * 11/12/2008 - BRACHYTHERAPY SOURCE'S STATUS INDICATOR = ' U' *
      *              EFFECTIVE 1/1/2009                             *
      *                                                             *
      * 11/16/2009 - REMOVED LOGIC FOR THERAPEUTIC RADIOPHARMS &    *
      *              BRACHYTHERAPY SOURCES B/C THESE ARE NOT PAID   *
      *              AT COST FOR CY 2010                            *
      *                                                             *
      * 04/11/2011 - ADDED LOGIC TO PREVENT LINES WITH PAFS 9 OR 10 *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      * 05/13/2016 - ADDED LOGIC FOR BLOOD DEDUCTIBLE LINES ON A    *
      *              COMPREHENSIVE APC CLAIM (ZERO OUT REIM, COIN,  *
      *              & NON-BLOOD DEDUCTIBLE)                        *
      *                                                             *
      * 10/23/2018 - ADDED LOGIC TO PREVENT LINES W/PAFS 23  OR 24  *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * FOR BLOOD DEDUCTIBLE LINES ON A COMPREHENSIVE APC CLAIM:    *
      * SET REIMBURSEMENT, COINSURANCE, & DEDUCTIBLE AMOUNTS TO $0  *
      *-------------------------------------------------------------*
             IF PKG-BLD-DED-LINE
                MOVE 0 TO H-LITEM-REIM
                          H-TOTAL-LN-DEDUCT
                          H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 18550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE REIMBURSEMENT AND SET COINSURANCE AMOUNTS TO $0   *
      * FOR LINES WITH A PAF= 9 OR 10 OR 23 OR 24                   *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 9' OR '10' OR '23'
                                                OR '24')
                COMPUTE H-LITEM-REIM ROUNDED =
                   H-LITEM-PYMT - H-TOTAL-LN-DEDUCT
                MOVE 0 TO H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 18550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                  H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX).
      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * FOR SECTION 603 SERVICES -                                  *
      * SET MIN, MAX, AND REDUCED COINSURANCE TO PSF STANDARD       *
      * FOR LINES WITH A PMF= 7 OR 8                                *
      *-------------------------------------------------------------*
             IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                OPPS-SITE-SRVC-FLAG (LN-SUB) = '8'
                COMPUTE H-MIN-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                COMPUTE H-MAX-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                MOVE 0  TO H-RED-COIN

                GO TO 18550-CALC-STANDARD-EXIT
             END-IF.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DEVICES, BRACHYTHERAPY, & BLOOD                             *
      * (SI = H LINES HAVE A MIN-COIN = 0, WON'T ENTER LOGIC)       *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) =
                  ' H' OR ' R' OR ' U'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       18550-CALC-STANDARD-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE LINE'S DEVICE CREDIT AMOUNT                   *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - REVISED LOGIC IMPLEMENTED APRIL 2016           *
      *                                                             *
      ***************************************************************
       18550-DEVICE-CREDIT.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE CREDIT     *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-DEVCR-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-DEVCR-PYMTS.

           COMPUTE H-LINE-DEVCR-AMT ROUNDED =
                   H-CLAIM-DEVCR-AMT * H-LINE-DEVCR-PYMT-RATE.

       18550-DEVICE-CREDIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE TERMINATED PROCEDURE LINE'S DEVICE OFFSET     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - NEW FOR CY 2016 (APRIL IMPLEMENTATION)         *
      *                                                             *
      ***************************************************************
       18550-TERM-PROC-DEV-OFF.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE OFFSET     *
      * FOR TERMINATED PROCEDURES                                   *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-TPDO-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-TPDO-PYMTS.

           COMPUTE H-LINE-TPDO-AMT ROUNDED =
                   L-PAYER-ONLY-VC-QQ * H-LINE-TPDO-PYMT-RATE.

      *-------------------------------------------------------------*
      * ADJUST THE BASE APC PAYMENT BY THE DEVICE OFFSET            *
      *-------------------------------------------------------------*
           IF W-APC-PYMT (W-LP-INDX) >= H-LINE-TPDO-AMT
              COMPUTE W-APC-PYMT (W-LP-INDX) ROUNDED =
                      W-APC-PYMT (W-LP-INDX) - H-LINE-TPDO-AMT
           ELSE
              MOVE 0 TO W-APC-PYMT (W-LP-INDX)
           END-IF.

       18550-TERM-PROC-DEV-OFF-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *        FOR LINES WITH A SI OF S, V, T, P, X, R, OR U        *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA OR THE     *
      *   L-PSF-PYMT-CBSA MUST BE A VALUE OF                        *
      *   '   01' THRU '   99' AND THE L-PSF-PROV-TYPE              *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2017: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      * 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES (SI=R)     *
      *              ADDED TO LOGIC.  BRACHY LINES NOT PROCESSED IN *
      *              PARAGRAPH & NOW HAVE A SI = U, SI = K LOGIC    *
      *              REMOVED FROM THIS PARAGRAPH.                   *
      * 05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD    *
      *              DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.     *
      *              FIX EFFECTIVE RETROACTIVE TO 01/01/2009.       *
      * 11/17/2009 - BRACHYTHERAPY LINES NOW PROCESSED IN THIS      *
      *              PARAGRAPH FOR CY 2010 (SI=U), DO NOT RECEIVE   *
      *              WAGE ADJUSTMENT                                *
      * 05/09/2011 - REVISED LOGIC TO EXCLUDE BILL TYPE 14X FROM    *
      *              RECEIVING THE SCH ADD-ON                       *
      * 02/07/2012 - REPLACE BILL14X-FLAG WITH CONDITION NAME       *
      *              BILL-TYPE-14X                                  *
      * 01/27/2014 - WHEN APPLICABLE, SUBTRACT DEVICE CREDIT        *
      *              AMOUNT FROM LINE ITEM PAYMENT                  *
      * 10/21/2016 - EXCLUDE SECTION 603 SERVICE LINES FROM SCH ADJ *
      * 06/12/2017 - IF THE GEOGRAPHIC, WAGE INDEX, OR PAYMENT CBSA *
      *              IS RURAL, APPLY THE RURAL SCH ADJ. TO THE LINE *
      *              PAYMENT. ADDED L-PSF-PYMT-CBSA CY2017          *
      ***************************************************************
       18550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.
             MOVE L-PSF-PYMT-CBSA TO PYMT-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      *   - SECTION 603 SERVICES EXCLUDED FROM THE SCH ADJUSTMENT   *
      ***************************************************************

             IF (RURAL-GEO OR RURAL-WI OR RURAL-PYMT) AND
                (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22') AND
                (NOT BILL-TYPE-14X) AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7') AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8')
      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*

                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      ***************************************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = R (BLOOD) OR U (BRACHY) LINES ARE NOT WAGE-ADJUSTED    *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U'
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.
      *-------------------------------------------------------------*
      * REDUCE ADJUSTED APC PAYMENT BY DEVICE CREDIT IF APPLICABLE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-LINE-DEVCR-AMT > 0
                IF H-LITEM-PYMT >= H-LINE-DEVCR-AMT
                   COMPUTE H-LITEM-PYMT ROUNDED =
                           H-LITEM-PYMT - H-LINE-DEVCR-AMT
                ELSE
                   MOVE 0 TO H-LITEM-PYMT
                END-IF
             END-IF.


       18550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = R & U LINES:         *
      *   - APC PAYMENT FOR BLOOD LINES (SI = R)                    *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = U LINES                      *
      *   - SCH ADJUSTMENT APPLIED TO BLOOD & BRACHY LINES          *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      * - 11/12/2008 - FOR CY 2009, BRACHYS NOT PROCESSED IN THIS   *
      *   PARAGRAPH; BRACHY LINES ASSIGNED A NEW SI OF ' U'         *
      * - 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES HAVE A   *
      *   SI = R                                                    *
      * - 12/05/2008 - MODIFIED LOGIC TO SEND BLOOD LINES WITHOUT   *
      *   A PMT ADJ FLAG = 5 OR 6 TO THE SCH ADJUSTMENT PARAGRAPH,  *
      *   INCLUDED SI = R IN THE BLOOD IDENTIFICATION LOGIC         *
      * - 11/15/2009 - BRACHYTHERPY SERVICES (SI = U) & THERAPEUTIC *
      *   RADIOPHARMS (SI = K) SENT TO THIS PARAGRAPH FOR CY 2010,  *
      *   LOGIC ALTERED TO PROCESS SI = U (RECEIVE REGULAR APC PMT) *
      * - 11/17/2009 - SEND BRACHYTHERAPY LINES TO 10550-SCH-ADJ TO *
      *   MAKE ELIGIBLE FOR SCH ADJUSTMENT, NOT WAGE ADJUSTED       *
      * - 05/10/2016 - ADDED LOGIC FOR SPECIAL HANDLING OF BLOOD    *
      *   DEDUCTIBLE LINES ON CLAIMS WITH A COMPREHENSIVE APC       *
      * - 11/2016 - REMOVED LOGIC FOR SI = G & K LINES (DRUGS)      *
      *                                                             *
      ***************************************************************
       18550-CALC-RU.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 18550-SET-BLOOD-FRACTION
                     THRU 18550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 18550-ADJ-BLOOD-COST
                     THRU 18550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 18550-SCH-ADJ
                     THRU 18550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * CHANGE THE PAYMENT OF THE BLOOD DEDUCTIBLE LINE ON THE SAME *
      * CLAIM AS A COMPREHENSIVE APC TO THE BLOOD DEDUCTIBLE AMOUNT *
      *-------------------------------------------------------------*
                  IF PKG-BLD-DED-LINE
                      MOVE H-LN-BLOOD-DEDUCT TO H-LITEM-PYMT
                  END-IF

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE, BUT PAF = 5 OR 6           *
      * (BLOOD PROCESSING AND PRODUCT BILLED TOGETHER)              *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 18550-ADJ-PLATE-COST
                      THRU 18550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 18550-SCH-ADJ
                      THRU 18550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE AND PAF NOT EQUAL TO 5 OR 6 *
      * (ONLY BLOOD PRODUCT BILLED)                                 *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 12/05/2008 - 7550-SCH-ADJ PERFORM ADDED FOR BLOOD LINES     *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 18550-SCH-ADJ
                      THRU 18550-SCH-ADJ-EXIT
                ELSE
                   IF OPPS-SRVC-IND (LN-SUB) = ' U'
                      PERFORM 18550-SCH-ADJ
                         THRU 18550-SCH-ADJ-EXIT
                   END-IF
                END-IF
             END-IF
             END-IF.

       18550-CALC-RU-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       18550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       18550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       18550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       18550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       18550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       18550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *           CALCULATE PAYMENT FOR PAID AT COST LINES          *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 08-11-2010 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED       *
      * 11-17-2015 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED AGAIN *
      * 08-18-2016 - USE DEVICE CCR WHEN AVAILABLE                  *
      *                                                             *
      ***************************************************************
       18555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST - "PAID AT COST"         *
      * (IF NO DEVICE CCR USE HOSPITAL CCR)                         *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

              IF L-PSF-DEVICE-CCR = 0
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG *  L-PSF-OPCOST-RATIO)
              ELSE
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG * L-PSF-DEVICE-CCR)
              END-IF.

      *-------------------------------------------------------------*
      * FOR PASS-THROUGH DEVICE LINE WITH AN ASSOCIATED OFFSET,     *
      * APPLY THE OFFSET (INDICATED BY PAF = '12' OR '13' OR '15'   *
      * (NOT CURRENTLY USING PAF '15')                              *
      *-------------------------------------------------------------*
              IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12' OR
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13' OR
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
                 PERFORM 18556-CALC-PTD-OFFSET
                    THRU 18556-CALC-PTD-OFFSET-EXIT
              END-IF.

      *-------------------------------------------------------------*
      * CAPTURE PAYMENT AMOUNT                                      *
      *-------------------------------------------------------------*
             IF T-LITEM-PYMT < 0 THEN
                MOVE 0 TO H-LITEM-PYMT
             ELSE
                MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

       18555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *   REDUCE LINE ITEM PAYMENTS OF PASS-THROUGH DEVICES THAT    *
      * HAVE AN ASSOCIATED PROCEDURE ON THE CLAIM BY THE PROCEDURE  *
      *                WAGE-ADJUSTED OFFSET AMOUNT                  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ** EFFECTIVE 11/13/2015 - REVISED PT DEVICE OFFSET LOGIC    *
      *                                                             *
      ***************************************************************
       18556-CALC-PTD-OFFSET.

      *-------------------------------------------------------------*
      * DETERMINE WHICH VARIABLES TO USE IN CALCULATIONS            *
      *-------------------------------------------------------------*
            INITIALIZE H-TOT-PTD-CHARGES
                       H-WA-PTD-OFFSET.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
               MOVE H-QN-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QN-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
               MOVE H-QO-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QO-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *     IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *        MOVE H-QP-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
      *        MOVE H-QP-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
      *     END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHAT % OF THE OFFSET WILL BE APPLIED              *
      *-------------------------------------------------------------*
            IF H-TOT-PTD-CHARGES > 0
               COMPUTE W-PTDO-CHRG-RATE ROUNDED =
                       H-SUB-CHRG / H-TOT-PTD-CHARGES
            ELSE
               GO TO 18556-CALC-PTD-OFFSET-EXIT
            END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE TAKEN                     *
      *-------------------------------------------------------------*
            COMPUTE W-PTDO-LINE-OFFSET ROUNDED =
                    W-PTDO-CHRG-RATE *
                    H-WA-PTD-OFFSET.

      *-------------------------------------------------------------*
      * SUBTRACT THE OFFSET AMOUNT FROM THE LINE PAYMENT            *
      *-------------------------------------------------------------*
            IF W-PTDO-LINE-OFFSET <= T-LITEM-PYMT
               COMPUTE T-LITEM-PYMT ROUNDED =
                       T-LITEM-PYMT - W-PTDO-LINE-OFFSET
            ELSE
               MOVE 0 TO T-LITEM-PYMT
            END-IF.


       18556-CALC-PTD-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       18560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * LINES INELIGIBLE FOR DEDUCTIBLE SKIP DEDUCTIBLE CALCULATION *
      * EFF. 7/1/2009 - CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      * ASSIGNED A PAF = ' 4'                                       *
      * - 04/11/2011 - ADDED PAF 9 FOR SERVICES WHERE THE           *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *   (ADDED FOR PREVENTIVE SERVICES WAIVER IN CY 2011)         *
      * - 10/23/2018 - ADDED PAF 23 & 24  FOR SERVICES WHERE THE    *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 4' OR ' 9' OR '23'
                                                OR '24')
                GO TO 18560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       18560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      * - 11/12/2008: FOR CY 2009, BRACHYS SI = U AND BLOOD SI = R  *
      *   BRACHY INELIGIBLE FOR OUTLIER, BLOOD ELIGIBLE FOR OUTLIER *
      *                                                             *
      * - 12/05/2008: ADDED SI = K TO LIST OF SIS INELIGIBLE FOR    *
      *   OUTLIER (BRACHYS & BLOOD NO LONGER HAVE SI = K)           *
      *                                                             *
      * - 11/17/2009: REMOVED U FROM LIST OF SIS INELIGIBLE FOR     *
      *   OUTLIER; BRACHYS NOW ELIGIBLE B/C NOT PAID AT COST CY 2010*
      *                                                             *
      * - 12/16/2009: ADDED SIS R AND U TO LOGIC THAT DISTRIBUTES   *
      *   PACKAGED CHARGES TO PAYABLE LINES. V2010.1.2              *
      *                                                             *
      * - 11/04/2011: MODIFIED LOGIC TO APPLY THE PHP CAP ONLY TO   *
      *   PHP CMHC LINES, NOT PHP HOSPITAL LINES PER POLICY'S       *
      *   INSTRUCTIONS                                              *
      *                                                             *
      * - 11/17/2015: MODIFIED LOGIC TO STOP ACCOUNTING FOR         *
      *   PASS-THROUGH DEVICE PAYMENTS AND CHARGES IN ASSOCIATED    *
      *   PROCEDURE'S OUTLIER CALCULATION.  ADDED STATUS INDICATOR  *
      *   'J2' AS ELIGIBLE FOR OUTLIER AND TO RECEIVED PACKAGED     *
      *   CHARGES                                                   *
      *                                                             *
      * - 05/10/2016: ADDED LOGIC TO EXCLUDE LINES ELIGIBLE FOR THE *
      *   BLOOD DEDUCTIBLE AND ON A CLAIM WITH A COMPREHENSIVE APC  *
      *   FROM THE OUTLIER PAYMENT                                  *
      *                                                             *
      * - 10/21/2016: ADDED LOGIC TO EXCLUDE SECTION 603 SERVICE    *
      *   LINES FROM THE OUTLIER PAYMENT (PMF = 7 OR 8)             *
      *                                                             *
      ***************************************************************
       18600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * SERVICE LINES NOT ELIGIBLE FOR AN OUTLIER PAYMENT:          *
      *   DEVICES, PACKAGED, PACKAGED AS PART OF DRUG ADMIN, AND    *
      *   SECTION 603 SERVICES                                      *
      *-------------------------------------------------------------*
      * 11/12/2008 - BRACHY (SI=U) ADDED TO LIST                    *
      * 12/05/2008 - SI K ADDED TO THE LIST                         *
      * 11/16/2009 - REMOVED PAF=2 FROM BRACHY (SI=U) CRITERIA      *
      * 11/17/2009 - REMOVE SI=U, BRACHYS ARE ELIGIBLE FOR OUTLIER  *
      * 07/26/2016 - REMOVE SI=G SI=K                               *
      * 10/21/2016 - SECTION ADDED 603 SERVICES (PMF = 7 OR 8)      *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' H' OR ' N') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8')
                   GO TO 18600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * BLOOD LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND ON A      *
      * CLAIM WITH A COMPREHENSIVE APC NOT ELIGIBLE FOR OUTLIER     *
      *-------------------------------------------------------------*
      * 05/10/2016 - NEW FOR JULY 2016                              *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  GO TO 18600-ADJ-CHRG-OUTL-EXIT
             END-IF.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                           ' X' OR ' P' OR ' R' OR
                                           ' U' OR 'J1' OR 'J2') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                          ' X' OR ' P' OR ' R' OR
                                          ' U' OR 'J1' OR 'J2') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A COMPOSITE ADJ.     *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 01 - NN...) ARE ACCUMULATED BY COMPOSITE            *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME        *
      * (PAYABLE) LINE'S CHARGES.                                   *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2007 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      * 11/12/2008 - CHANGED LOGIC TO USE THE COMPOSITE ADJUSTMENT  *
      *              FLAG INSTEAD OF THE PAYMENT ADJUSTMENT FLAG    *
      *              VALUES 91 - 99 TO ID PRIME COMPOSITE LINES     *
      ***************************************************************

      *-------------------------------------------------------------*
      * COMPOSITE ADJUSTMENT FLAG > 0 INDICATES COMPOSITE APC       *
      *-------------------------------------------------------------*
           IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = '00'

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.


      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD                          *
      *   (ALWAYS USE THE PHP "CAP" APC'S WAGE ADJ PMT FOR PHP LINES*
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED BECAUSE PAYMENTS MAY BE ADJUSTED FOR     *
      *              PASS-THROUGH DEVICES                           *
      * ??/??/2008 - NEW FOR CY 2009 - ALWAYS USE THE PHP "CAP"     *
      *              APC'S WAGE ADJ "CAP" PMT FOR PHP LINES (SI=P)  *
      * 11/04/2011 - ONLY APPLY PHP "CAP" TO CMHC LINES; PER        *
      *              POLICY'S INSTRUCTIONS PHP HOSPITAL LINES ARE   *
      *              NOT CAPPED.                                    *
      * 11/17/2015 - CONTINUE TO USE THIS LOGIC EVEN THOUGH PAYMENTS*
      *              ARE NO LONGER ADJUSTED FOR PT DEVICES          *
      * 10/26/2016 - DISABLED CMHC PHP PMT CAP BECAUSE ALL PHP CMHCS*
      *              USE THE SAME APC EFFECTIVE JANUARY 2017        *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL.


      ***************************************************************
      *                                                             *
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      * -NEW FOR JANUARY 2009                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE PHP "CAP" APC'S LINE PAYMENT                        *
      *                                                             *
      * -NEW FOR JANUARY 2017                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE SAME PHP APC (NO NEED TO CAP PMT)                   *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      * (CMHC PROVIDERS ONLY PROCESS PARTIAL HOSPITALIZATION LINES) *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT

      ***************************************************************
      *     ADD LOGIC TO PREVENT NEGATIVE OUTLIER PAYMENT           *
      ***************************************************************
                   IF H-LITEM-OUTL-PYMT < 0
                      MOVE 0 TO H-LITEM-OUTL-PYMT
                   END-IF


      *-------------------------------------------------------------*
      *     FOR CMHC PROVIDERS THAT ARE SUBJECT TO THE OUTLIER CAP, *
      *     ACCUMULATE CLAIM PAYMENT AND OUTLIER TOTALS             *
      *-------------------------------------------------------------*
                   IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '0'
                        COMPUTE H-CMHC-PYMT-TOTAL =
                          H-CMHC-PYMT-TOTAL + H-LITEM-PYMT-OUTL

                        COMPUTE H-CMHC-OUTL-TOTAL =
                          H-CMHC-OUTL-TOTAL + H-LITEM-OUTL-PYMT
                   END-IF

      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE

                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 4825)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT
                  END-IF
               END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT.


      *-------------------------------------------------------------*
      * LINES THAT ARE NOT ELIGIBLE FOR AN OUTLIER PAYMENT BECAUSE  *
      * OUTLIER CAP WAS MET BEFORE THIS CLAIM WAS PROCESSED -       *
      * ZERO OUT LINE OUTLIER PAYMENT & REMOVE FROM CLAIM TOTAL     *
      * 8/21/16 -MOVE 2 TO RETURN CODE, IF FLAG = 6 & OUTL PYMT > 0 *
      *-------------------------------------------------------------*
             IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6')
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT
                MOVE 02 TO A-CLM-RTN-CODE.


       18600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *               CAP CMHC TOTAL OUTLIER PAYMENTS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      * FOR CMHC CLAIMS ONLY, DO THE FOLLOWING:                     *
      *                                                             *
      * - DETERMINE IF THE TOTAL CLAIM OUTLIER PAYMENT ELIGIBLE     *
      *   FOR CAPPING IS > $0                                       *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS PAYMENTS INCLUDING THE *
      *   CURRENT CLAIM'S PAYMENTS                                  *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS OUTLIER PAYMENTS       *
      *   INCLUDING THE CURRENT CLAIM'S OUTLIER PAYMENTS            *
      * - CALCULATE THE CURRENT OUTLIER PERCET                      *
      * - IF THE OUTLIER PERCENT EXCEEDS THE CAP:                   *
      *   - SET THE CLAIM OUTLIER TO $0                             *
      *   - SET THE RETURN CODE TO 02                               *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JULY 2017, EFFECTIVE JANUARY 2017                 *
      *                                                             *
      ***************************************************************
       18610-CMHC-OUTL-CAP.
             IF ( (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999') ) AND
                H-CMHC-OUTL-TOTAL > 0

      *-------------------------------------------------------------*
      *            CALCULATE PROVIDER'S TOTAL PAYMENTS              *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-PYMT-TOTAL =  H-CMHC-PYMT-TOTAL +
                        L-PRIOR-PYMT-TOTAL

      *-------------------------------------------------------------*
      *       CALCULATE PROVIDER'S TOTAL OUTLIER PAYMENTS           *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTL-TOTAL =  H-CMHC-OUTL-TOTAL +
                        L-PRIOR-OUTL-TOTAL

      *-------------------------------------------------------------*
      *                 CALCULATE OUTLIER PERCENT                   *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTLIER-PCT ROUNDED =
                   H-CMHC-OUTL-TOTAL / H-CMHC-PYMT-TOTAL

      *-------------------------------------------------------------*
      *                     APPLY OUTLIER CAP                       *
      *-------------------------------------------------------------*
                IF H-CMHC-OUTLIER-PCT > CMHC-OUTL-CAP-PCT
                   MOVE 0 TO H-OUTLIER-PYMT
                   MOVE 02 TO A-CLM-RTN-CODE
                END-IF
             END-IF.

       18610-CMHC-OUTL-CAP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 18550-CALC-RU &        *
      *      18550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES        *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       18655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9021' OR
                                    'P9056' OR
                                    'P9010' OR
                                    'P9016' OR
                                    'P9051' OR
                                    'P9038' OR
                                    'P9058' OR
                                    'P9040' OR
                                    'P9057' OR
                                    'P9054' OR
                                    'P9022' OR
                                    'P9039'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       18655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *        PROCESS COINSURANCE CAP ROLL-UP TABLE RECORDS        *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE BLOOD LINE COINSURANCE WHEN THE PROCEDURE       *
      *  COINSURANCE AMOUNTS PLUS THE BLOOD COINSURANCE AMOUNT(S)   *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       18800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 18810-PROCESS-TYPE1
                   THRU 18810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 18840-PROCESS-TYPE2
                   THRU 18840-PROCESS-TYPE2-EXIT.

       18800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH BLOOD COINSURANCE, DETERMINE THE  *
      *  % OF TOTAL BLOOD COINSURANCE THAT CAN BE PAID IN ADDITION  *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE BLOOD COINSURANCE CAN BE PAID*
      *  WHEN H-RATIO = 1, ALL OF THE BLOOD COINSURANCE CAN BE PAID *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       18810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * BLOOD WAS ADMINISTERED ON THE DAY                           *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & ACTUAL COINSURANCE OF THE             *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-COIN1 (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL BLOOD COIN THAT CAN BE   *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      * CHANGED NATIONAL COINSURANCE TO ACTUAL COINSURANCE FOR      *
      * CY2018                                                      *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-COIN1 (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S BLOOD COIN CAN BE PAID B/C THE PROCEDURE/ *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL BLOOD COINSURANCE CAN BE PAID WITHIN THE    *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       18810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE BLOOD LINE'S NATIONAL COINSURANCE AMOUNT AND    *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       18840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 BLOOD COIN REC HAS SAME DATE OF SERVICE AS   *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE BLOOD COIN RECORD*
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE BLOOD LINE BY  *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD BLOOD COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT   *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       18840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       18900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       18900-END-PRICE-RTN-EXIT.
           EXIT.




      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 19000 FOR CALENDAR YEAR 2020 PROCESSING        **
      **          SERVICE FROM DATES: 1/1/2020 - 12/31/2020           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE IOCE)      *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  7. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  8. CALCULATE SERVICE LINE PAYMENTS                            *
      *  9. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 10. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 11. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 12. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 13. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, AND COMPOSITE *
      *     CHARGES OF APPLICABLE PROCEDURES.                          *
      *     ALL ADJUSTMENTS ARE DONE FOR OUTLIER DETERMINATION ONLY.   *
      * 14. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 15. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR BLOOD LINES; *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE BLOOD LINE'S REIMBURSEMENT                    *
      * 16. ACCUMULATE CLAIM TOTALS                                    *
      * 17. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       19000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY),  *
      *            DETERMINE CLAIM DEVICE CREDIT AMOUNT               *
      *            (CLAIM LEVEL INITIALIZATION)                       *
      *                                                               *
      *****************************************************************
              PERFORM 19100-INIT
                 THRU 19100-INIT-EXIT.

      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - C-APC-CLAIM-FLAG - COMPREHENSIVE APC ON CLAIM - FOR       *
      *     SPECIAL BLOOD DEDUCTIBLE LINE LOGIC                       *
      *                                                               *
      *****************************************************************
              PERFORM 19125-INIT
                 THRU 19125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.



      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH *
      *            RADIOPHARMACEUTICAL OFFSET, CREATE CONTRAST        *
      *            AGENT PROCEDURE TABLE FOR PASS-THROUGH CONTRAST    *
      *            AGENT OFFSET.                                      *
      *            (LOOP THROUGH THE CLAIM LINES)                     *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY TABLES FOR NEW CLAIM                             *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX    W-BLD-MAX    W-CMP-MAX.

              PERFORM 19150-INIT
                 THRU 19150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      *-------------------------------------------------------------*
      * CALCULATE WAGE-ADJUSTED PASS-THROUGH DEVICE OFFSETS         *
      * (VALUE CODES QN, QO & QP; CLAIM LEVEL)                      *
      * NEW FOR CY2016 - 11/13/2015                                 *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QN > 0
                COMPUTE H-QN-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QN * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QN * .40)
             END-IF.

             IF L-PAYER-ONLY-VC-QO > 0
                COMPUTE H-QO-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QO * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QO * .40)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF L-PAYER-ONLY-VC-QP > 0
      *         COMPUTE H-QP-WA-PTD-OFFSET ROUNDED =
      *                 ((L-PAYER-ONLY-VC-QP * .60) * H-WINX) +
      *                 (L-PAYER-ONLY-VC-QP * .40)
      *      END-IF.



      *****************************************************************
      *                                                               *
      *   STEP 4 - INITIALIZE W-DCP-MAX                               *
      *   ------                                                      *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, AND MOVE LINE ITEM         *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 19400-CALCULATE
                 THRU 19400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, AND COMPOSITES, AND CALCULATE  *
      *            OUTLIER PAYMENTS                                   *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 19600-ADJ-CHRG-OUTL
                 THRU 19600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.
              PERFORM 19610-CMHC-OUTL-CAP
                 THRU 19610-CMHC-OUTL-CAP-EXIT.

      *****************************************************************
      *                                                               *
      *   STEP 7 - RECALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS*
      *   ------   FOR STATUS INDICATOR R (BLOOD) LINES WHEN THE DAILY*
      *            INPATIENT DEDUCTIBLE CAP IS EXCEEDED.              *
      *            THE COINSURANCE CAP IS APPLIED USING THE WAGE      *
      *            ADJUSTED NATIONAL COINSURANCE OF EACH DAY'S MOST   *
      *            EXPENSIVE PROCEDURE OR VISIT.                      *
      *            (LOOP THROUGH THE COINSURANCE CAP ROLL-UP TABLE)   *
      *                                                               *
      *****************************************************************
                IF BLOOD-FLAG = 'Y'
                   PERFORM 19800-ADJ-STV-REIM
                      THRU 19800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                END-IF.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 19900-END-PRICE-RTN
                 THRU 19900-END-PRICE-RTN-EXIT.

       19000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY DEDUCTIBLE CAP (H-IP-LIMIT)            *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       19100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE FLAGS AND VARIABLES               *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 11/03/2008 - APC33-FLAG REPLACED BY PHP-APC-FLAG            *
      * 11/12/2008 - BRACHY-APC-FLAG REMOVED, NOT USED FOR CY 2009  *
      * 02/09/2009 - PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG ADDED    *
      * 11/16/2009 - RADIOPH-APC-FLAG REMOVED; PTCA-CLAIM-FLAG,     *
      *              PTCA-LINE FLAG ADDED                           *
      * 02/07/2012 - BILL14X-FLAG REMOVED                           *
      * 11/18/2013 - DEVCR-CLAIM-FLAG ADDED                         *
      * 11/18/2015 - REMOVED APC34-FLAG (MENTAL HEALTH), PTD-FLAG,  *
      *              PTD-LINE-FLAG, PTD-PROC-FLAG, AND              *
      *              C1820-OFFSET-FLAG BECAUSE THEY'RE NOT USED     *
      * 02/09/2016 - ADD LOGIC TO DETERMINE CLAIM'S DEVICE CREDIT   *
      * 02/10/2016 - DEVCR-CLAIM-FLAG REMOVED (NO LONGER USED)      *
      * 10/26/2016 - PHP-HCPCS-FLAG, MH-HCPCS-FLAG,                 *
      *              PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG,         *
      *              PTCA-CLAIM-FLAG, PTCA-LINE-FLAG REMOVED        *
      *              (NO LONGER USED)                               *
      *                                                             *
      *-------------------------------------------------------------*
             MOVE 'N'   TO BLOOD-FLAG
                           ST0-FLAG
                           N-FLAG
                           BLD-DEDUC-HCPCS-FLAG
                           C-APC-CLAIM-FLAG
                           PKG-BLD-DED-LINE-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO  TO A-OUTLIER-PYMT
                           A-TOTAL-CLM-DEDUCT
                           A-TOT-CLM-CHRG
                           A-TOT-CLM-PYMT
                           A-BLOOD-DEDUCT-DUE
                           A-BLOOD-PINTS-USED
                           A-WINX
                           W-LNC-MAX
                           A-DEVICE-CREDIT-QD.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
      *-------------------------------------------------------------*
      * INITIATILIZE WORKING STORAGE DATES - 10-23-2014             *
      *-------------------------------------------------------------*
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-BEGIN-YYYY.
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-END-YYYY.

      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 19100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 19100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 19100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION19 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE THE TOTAL DEVICE CREDIT AMOUNT TO BE DEDUCTED     *
      * FROM THE CLAIM - USE THE LESSER OF THE AMOUNT IN            *
      * VALUE CODE FD AND THE CAP AMOUNT IN VALUE CODE QU           *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QU > 0 AND
                L-DEVICE-CREDIT > 0
                IF L-PAYER-ONLY-VC-QU < L-DEVICE-CREDIT
                   MOVE L-PAYER-ONLY-VC-QU TO H-CLAIM-DEVCR-AMT
                ELSE
                   MOVE L-DEVICE-CREDIT TO H-CLAIM-DEVCR-AMT
                END-IF
             END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = 'D'
                      MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
                   ELSE
      *-------------------------------------------------------------*
      *   USE SPECIAL WAGE INDEX WHEN INDICATED                     *
      *   (PSF RECORD EFFECTIVE DATE MUST BE WITHIN THE CLAIM'S CY) *
      *   ADDED 10-23-2014 FOR CY 2015                              *
      *-------------------------------------------------------------*
                      IF (L-PSF-SPEC-PYMT-IND = '1' OR '2') AND
                         (L-PSF-EFFDT >= W-CY-BEGIN-DATE AND
                          L-PSF-EFFDT <= W-CY-END-DATE)
                          MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                          MOVE L-PSF-SPEC-WGIDX TO H-WINX
                          MOVE 1408 TO H-IP-LIMIT
                          GO TO 19100-INIT-EXIT
                      ELSE
                         MOVE  52  TO A-CLM-RTN-CODE
                         GO TO 19100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 19100-INIT-EXIT.

             MOVE 1408 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      * APPLY WAGE INDEX FLOOR POLICY                               *
      * (USE HIGHER OF CBSA WAGE INDEX AND STATE RURAL WAGE INDEX)  *
      *-------------------------------------------------------------*
      * 10-23-2014 - NEW FLOOR LOGIC FOR CY 2015                    *
      * 10-28-2015 - NEW STATE CODES ADDED FOR APRIL 2016           *
      *-------------------------------------------------------------*
      *-------------------------------------------------------------*
      * >FIRST, CONFIRM FLOOR SWITCH IS SET                         *
      *-------------------------------------------------------------*
             SET W-FLOOR-LOOKUP TO TRUE.
      *-------------------------------------------------------------*
      * >GET PROVIDER'S STATE CODE FOR RURAL FLOOR WAGE INDEX       *
      *  LOOK-UP (NEW FOR JULY 2016)                                *
      *-------------------------------------------------------------*
             MOVE L-PSF-STATE-CODE TO W-PSF-PROV-ST.

      *-------------------------------------------------------------*
      * >NOW, CALL WAGE INDEX LOOKUP AND LOOK FOR THE STATE FLOOR.  *
      *  STORE PSF-CBSA IN A-CBSA (IT GETS MOVED THERE IN THE NEXT  *
      *  STEP ANYWAY). THIS FREES H-PSF-CSBA FOR THE FLOOR SEARCH   *
      *  MOVE THREE SPACES + STATE CODE TO H-PSF-CBSA               *
      *  STORE RESULT IN H-WINX.                                    *
      *  MOVE A-CBSA BACK TO H-PSF-CBSA FOR CLEANUP                 *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             STRING '   ' DELIMITED BY SIZE
                   W-PSF-PROV-ST DELIMITED BY SIZE
                   INTO H-PSF-CBSA.
             PERFORM 19200-CALC-WAGEINDX
                THRU 19200-CALC-WAGEINDX-EXIT.
             MOVE A-CBSA TO H-PSF-CBSA.

      *-------------------------------------------------------------*
      * >GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN   *
      *  BY THE PSF SPECIAL WAGE INDEX VALUE)                       *
      *                                                             *
      *   NOTE: IF PSF SPECIAL WAGE INDEX VALUE USED,               *
      *         15100-INIT-EXIT WILL BE CALLED ABOVE - THIS CODE    *
      *         WILL NEVER BE REACHED. THEREFORE CHECKING FOR A 0   *
      *         VALUE SHOULD BE UNNECESSARY.                        *
      * >SET WAGE INDEX LOOKUP FLAG (FLOOR FLAG = 'N')              *
      *-------------------------------------------------------------*
             SET W-WINX-LOOKUP TO TRUE.
                PERFORM 19200-CALC-WAGEINDX
                   THRU 19200-CALC-WAGEINDX-EXIT.

      ***************************************************************
      * DETERMINE OUTMIGRATION ADJUSTMENT BASED ON COUNTY CODE, IF  *
      * WAGE INDEX CBSA FIELD AND STANDARDIZED AMOUNT CBSA FIELD    *
      * BLANK, AND SPECIAL PYMT INDICATOR ARE BLANK APPLY ADJUSTMENT*
      * IF NOT- DONT APPLY                                          *
      ***************************************************************
             IF ( L-PSF-WI-CBSA = '     ' OR
                  L-PSF-WI-CBSA = '00000') AND
                ( L-PSF-PYMT-CBSA = '     ' OR
                  L-PSF-PYMT-CBSA = '00000') AND
                  L-PSF-SPEC-PYMT-IND = ' '

      ***************************************************************
      * INITIALIZE OUTM-IND (INDICATOR) - CLEAR VARIABLE            *
      * SEARCH FOR OUTMIGRATION COUNTY CODE MATCH WITHIN TABLE,     *
      * AT FIRST OCCURENCE USE (OUTM-IDX2) AS POINTER (REFERENCE)   *
      * FOR (OUTM-IDX) INITIAL LINE LOCATION MATCH                  *
      ***************************************************************

                INITIALIZE OUTM-IND
                SET OUTM-IDX TO 1
                SEARCH OUTM-TAB VARYING OUTM-IDX
                   AT END
                      MOVE 0 TO OUTM-IND

                   WHEN OUTM-CNTY(OUTM-IDX) =
                    L-PSF-COUNTY-CODE
                    SET OUTM-IDX2 TO OUTM-IDX
                    MOVE 1 TO OUTM-IND
             END-IF.

      ***************************************************************
      * WHEN OUTM-IND = 1, THIS MEANS COUNTY CODE MATCH WAS FOUND   *
      * LOOP THRU EACH LINE THEN PERFORM PARAGRAPH UNTIL CONDITION  *
      * (IF-STATEMENT) IS TRUE, THE COUNTY CODES NO LONGER MATCH    *
      * ON LAST LINE OF DATE MATCH FOR COUNTY CODE, MOVE            *
      * OUTMIGRATION ADJUSTMENT, TO HLD-OUTM-ADJ VARIABLE           *
      * FOR COMPUTATION                                             *
      ***************************************************************
               IF OUTM-IND = 1
                 PERFORM 19120-GET-OUTM-ADJ THRU
                           19120-GET-OUTM-ADJ-EXIT
                  VARYING OUTM-IDX2 FROM OUTM-IDX BY 1 UNTIL
                OUTM-CNTY(OUTM-IDX2) NOT = L-PSF-COUNTY-CODE
      ***************************************************************
      * FOR FYS 2018 AND AFTER, APPLY THE OUTMIGRATION ADJUSTMENT   *
      * ADD OUT MIGRATION ADJUST TO WAGE INDEX FOR NEW H-WINX       *
      ***************************************************************
                COMPUTE H-WINX = H-WINX + HLD-OUTM-ADJ
               END-IF.
      ***************************************************************
      * PROVIDERS BELOW WAGE INDEX OF 0.8457 WILL RECIEVE A BOOST   *
      * IN THEIR WAGE INDEX.                                        *
      ***************************************************************
                 PERFORM 19121-WI-QUARTILE-ADJ THRU
                         19121-WI-QUARTILE-ADJ-EXIT.
      ***************************************************************
      * ALL PROVIDERS ELIGIBLE FOR TRANSITION DUE TO CHANGE         *
      * OF RURAL FLOOR POLICY: USING RURAL WAGE INDEX               *
      ***************************************************************
                 PERFORM 19122-WI-TRANSITION-ADJ THRU
                         19122-WI-TRANSITION-ADJ-EXIT.

       19100-INIT-EXIT.
           EXIT.

       19120-GET-OUTM-ADJ.
             IF OUTM-EFF-DATE(OUTM-IDX2) <= L-SERVICE-FROM-DATE AND
                OUTM-EFF-DATE(OUTM-IDX2) >= W-CY-BEGIN-DATE AND
                OUTM-EFF-DATE(OUTM-IDX2) <= W-CY-END-DATE
                 MOVE OUTM-ADJ-FACT(OUTM-IDX2) TO HLD-OUTM-ADJ
             END-IF.
       19120-GET-OUTM-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *              QUARTILE ADJUSTMENT OF WAGE INDEX              *
      ***************************************************************
      * PROVIDERS BELOW WAGE INDEX OF 0.8457 WILL RECIEVE A BOOST   *
      * IN THEIR WAGE INDEX.                                        *
      *   THIS WILL BE EFF. FOR 4 YEARS (CY2020 - CY2023)           *
      *       - THE STATIC 0.8457 WILL CHANGE EVERY YEAR            *
      *       - PLEASE UPDATE WI-QUARTILE-CY2020  ANNUALLY          *
      *                                                             *
      ***************************************************************
       19121-WI-QUARTILE-ADJ.

                IF H-WINX < WI-QUARTILE-CY2020
                   COMPUTE H-WINX ROUNDED =
                    ((WI-QUARTILE-CY2020 - H-WINX) / 2)
                     + H-WINX
                END-IF.

       19121-WI-QUARTILE-ADJ-EXIT.
           EXIT.

      ***************************************************************
      * ALL PROVIDERS ELIGIBLE FOR TRANSITION DUE TO CHANGE         *
      * OF RURAL FLOOR POLICY: USING RURAL WAGE INDEX               *
      *       - COMPARE CURRENT CY TO PREVIOUS CY WAGE INDEX        *
      *         IF WAGE INDEX GOES DOWN BY MORE THAN 5% BETWEEN     *
      *         CURRENT CY AND PREVIOUS CY ASSIGN PREVIOUS CY       *
      *         WAGE INDEX WITH A CAP OF THE 5% REDUCTION           *
      *       - IF PROVIDER WAGE INDEX NOT IN THE PREVIOUS WAGE     *
      *         INDEX TABLE RETURN CODE 50.                         *
      ***************************************************************
       19122-WI-TRANSITION-ADJ.

                PERFORM 19123-GET-PRIOR-CY-WI THRU
                        19123-GET-PRIOR-CY-WI-EXIT.

                IF  H-PREV-WINX = 0
                    GO TO 19122-WI-TRANSITION-ADJ-EXIT.

                IF (((H-WINX - H-PREV-WINX) / H-PREV-WINX)
                      < WI-PCT-REDUCT-CY2020)
                   COMPUTE H-WINX ROUNDED =
                      H-PREV-WINX * WI-PCT-ADJ-CY2020.

       19122-WI-TRANSITION-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *              SEARCH PRIOR YEAR WAGE INDEX TABLE             *
      ***************************************************************
       19123-GET-PRIOR-CY-WI.
                SET PREV-IDX TO 1.
                SEARCH PREV-TAB VARYING PREV-IDX
                    AT END
                       MOVE 50 TO A-CLM-RTN-CODE
                    WHEN PREV-PROV(PREV-IDX) =  L-PSF-PROV-OSCAR
                       MOVE PREV-WI(PREV-IDX) TO H-PREV-WINX.
       19123-GET-PRIOR-CY-WI-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND APC / HCPCS/ FLAGS  *
      *                                                             *
      *  - SET FLAG IF APC = 5851/5852/5861/5862 (PARTIAL HOSP.)    *
      *  - SET FLAG IF PASS-THROUGH RADIOPHARMS(S) ON CLAIM         *
      *    (NEW FOR APRIL CY 2009 - ADDED 02/10/2009)               *
      *  - SET FLAG IF PASS-THROUGH CONTRAST AGENT(S) ON CLAIM      *
      *    (NEW FOR JANUARY CY 2010 - ADDED 11/15/2009)             *
      *  - SET FLAG IF CLAIM IS ELIGIBLE FOR DEVICE CREDIT          *
      *    (NEW FOR JANUARY CY 2014)                                *
      *  - SET FLAG IF CLAIM HAS A COMPREHENSIVE APC (C-APC) LINE   *
      *    (NEW FOR JULY 2016)                                      *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION HCPCS FROM     *
      *              0033 TO 0172 & 0173 FOR CY 2009                *
      *                                                             *
      * 11/12/2008 - HCPCS C1820 EXPIRED FROM PASS-THROUGH STATUS   *
      *              DECEMBER 2007, OFFSET FLAG LOGIC DISABLED      *
      *                                                             *
      * 08/02/2010 - ADDED LOGIC TO SET PASS-THOUGH DEVICE FLAG FOR *
      *              DEVICE OFFSETS AND POPULATE THE CORRESPONDING  *
      *              TABLE                                          *
      *                                                             *
      * 11/15/2010 - ADDED APCS 0175 & 0176 TO LIST OF PHP APCS     *
      *                                                             *
      * 11/18/2013 - ADDED LOGIC TO SET DEVICE CREDIT CLAIM FLAG    *
      *                                                             *
      * 11/17/2015 - REMOVED LOGIC TO SET FLAGS FOR PASS-THROUGH    *
      *              DEVICES (FOR OUTLIER & OFFSET LOGIC)           *
      *            - UPDATED PHP APCS FOR 2016                      *
      *            - REMOVED APC34-FLAG (MENTAL HEALTH) - NOT USED  *
      *            - REMOVED APC 0339 UNITS OVERRIDE                *
      *                                                             *
      * 05/09/2016 - ADDED LOGIC TO SET COMPREHENSIVE APC CLAIM FLAG*
      * 10/26/2016 - REMOVED PHP APC CHECK, PT RADIOPHARM CHECK,    *
      *              AND PT CONTRAST AGENT CHECK                    *
      *                                                             *
      ***************************************************************
       19125-INIT.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A COMPREHENSIVE APC     *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = 'J1' OR
                OPPS-SRVC-IND (LN-SUB) = 'J2'
                MOVE 'Y' TO C-APC-CLAIM-FLAG
             END-IF.


       19125-INIT-EXIT.
           EXIT.




      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0, 6, 7, 8,    *
      *                9, OR 'A' (PAYMENT METHOD FLAG)              *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       19150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 19250-CALC-DISCOUNT
                THRU 19250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 19150-INIT-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 10/26/2016 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG REMOVED         *
      *-------------------------------------------------------------*
             MOVE 'N' TO PKG-BLD-DED-LINE-FLAG.


      ***************************************************************
      *   IDENTIFY LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE ON       *
      *   A CLAIM WITH A COMPREHENSIVE APC; TREAT AS PACKAGED LINE  *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      ***************************************************************
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             END-IF.


      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR ' L' OR
                ' N' OR ' P' OR ' R' OR ' S' OR ' T' OR ' U' OR
                ' V' OR ' X' OR ' W' OR ' Y' OR ' Z' OR ' M' OR
                'J1' OR 'J2')
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 19150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' K' OR ' L' OR ' W' OR
                ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 19150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      * 10/26/2016- REMOVED PHP/MENTAL HEALTH CODE LISTS            *
      * 01/19/2017- ADDED '3' INTO LOGIC, FOR FISS INFORMATINAL USE *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF  OPPS-LITEM-DR-FLAG (LN-SUB) = ('0' OR '3') OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                       OPPS-LITEM-ACT-FLAG (LN-SUB) = '1'



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      * 11/03/2008 - REMOVED PAFS 91 - 99 FOR COMPOSITES FOR CY 2009*
      * 04/11/2011 - ADDED ' 9' & '10' AS VALID PAFS FOR CY 2011    *
      * 12/18/2014 - ADDED '11' FOR CY 2015                         *
      * 11/10/2015 - ADDED '12' - '14' FOR CY 2016                  *
      * 02/05/2016 - ADDED '16' - '20' FOR CY 2016                  *
      *              (PAF '15' RESERVED FOR FUTURE USE)             *
      * 08/11/2016 - ADDED '21' FOR CY 2016                         *
      * 10/16/2017 - ADDED '22' FOR CY 2018                         *
      * 10/23/2018 - ADDED '23' FOR CY 2019                         *
      * 10/23/2018 - ADDED '24' FOR CY 2019                         *
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8' OR ' 9' OR '10' OR '11'
                             OR '12' OR '13' OR '14'         OR '16'
                             OR '17' OR '18' OR '19' OR '20' OR '21'
                             OR '22' OR '23' OR '24'


      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *                                                             *
      *   ** SITE OF SERVICE FLAG = PAYMENT METHOD FLAG IN OCE **   *
      *                                                             *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', PHP APC IS ON THE CURRENT LINE       *
      *-------------------------------------------------------------*
      * 11/06/2007 - CHANGED PHP HEALTH CODES LISTED FROM           *
      *              APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008   *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION APC FROM       *
      *              0033 TO 0172 & 0173 FOR CY 2009, FLAG CHANGED  *
      *              FROM APC33-FLAG TO PHP-APC-FLAG                *
      * 10/19/2016 - ADDED VALUES '7' AND '8' FOR SECTION 603       *
      *              SERVICE LINES (MODIFIER 'PN')                  *
      * 10/26/2016 - REMOVED PHP SPECIFIC LOGIC                     *
      * 03/02/2017 - ADD PMF FLAG '9' VALUE TO VALID LIST           *
      * 11/05/2018 - ADD PMF FLAG 'A' VALUE TO VALID LIST           *
      * 11/12/2019 - ADD PMF FLAG 'Y' VALUE TO VALID LIST           *
      * 12/02/2019 - ADD PMF FLAG 'X' VALUE TO VALID LIST           *
      * 12/02/2019 - ADD PMF FLAG 'Z' VALUE TO VALID LIST           *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '9') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'A') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Z')



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE ALL PACKAGED COMPOSITE LINES                      *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *   11/12/2008 - CHANGED LOGIC THAT EXCLUDES ALL COMPOSITE    *
      *                LINES & MENTAL HEALTH PKG LINES TO USE THE   *
      *                COMPOSITE ADJUSTMENT FLAG INSTEAD OF PAYMENT *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *   05/09/2016 - ADDED LOGIC TO ENSURE BLOOD DEDUCTIBLE LINES *
      *                ON CLAIMS WITH A COMPREHENSIVE APC ARE       *
      *                INCLUDED                                     *
      *-------------------------------------------------------------*
                IF ( (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                     (OPPS-COMP-ADJ-FLAG (LN-SUB) = '00') ) OR
                     PKG-BLD-DED-LINE
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED REVENUE CODE 39X BLOOD LINE CHARGES   *
      *   (BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC)      *
      *   WHEN BILLED ON CLAIM WITH A COMPREHENSIVE APC TO          *
      *   DETERMINE THE PORTION OF THE BLOOD APC PAYMENT TO BE      *
      *   DISTRIBUTED TO THE BLOOD PRODUCT (PAF = 5) LINE FOR THE   *
      *   BLOOD DEDUCTIBLE CALCULATION                              *
      *-------------------------------------------------------------*
      *   05/16/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' N' AND
               (OPPS-LITEM-RVCD (LN-SUB) = '0390' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0392' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0399')
                  COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB) +
                                          H-TOT-38X-39X
             END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME (PACKAGED) COMPOSITE APC CHARGES     *
      *   FOR EACH COMPOSITE APC BY THE COMPOSITE ADJUSTMENT FLAG   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2007 - LOGIC REVISED FOR CY 2009 TO IDENTIFY ALL    *
      *                COMPOSITE LINES USING THE COMPOSITE          *
      *                ADJUSTMENT FLAG INSTEAD OF PAYMENT           *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *                (INCLUDES PROCESSING FOR MENTAL HEALTH       *
      *                 COMPOSITES)                                 *
      *-------------------------------------------------------------*
                IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "00" AND
                   OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "  " AND
                   OPPS-SRVC-IND (LN-SUB) = ' N'
                      PERFORM 19170-COMPOSITES
                         THRU 19170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   SET RETURN CODE & EXIT WHEN PACKAGED LINE/LINE APC = 0000 *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 19150-INIT-EXIT
                END-IF


      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 19150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 19175-APC-LOOKUP

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT METHOD FLAG = '8' (603 SV)*
      *   SET THE COINSURANCE AND REIMBURSEMENT TO PFS RATES        *
      *   10/16/2017 - NEW FOR CY 2018; PAYS 40% OFF THE OPPS RATE  *
      *   11/08/2019 - PAYS 40% OFF THE OPPS RATE                   *
      *   11/12/2019 - ADD PMF = 'Y' TO PMF = '8' LOGIC (603 SV)    *
      *   12/02/2019 - ADD PMF = 'X' TO PMF = '7' LOGIC (603 SV)    *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '8' OR 'Y'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * PFS-REDUCT-2018
                      END-IF

                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = '8' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y'
                         COMPUTE H-MIN-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         COMPUTE H-NAT-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         MOVE    PFS-REIM-RATE TO H-PPCT
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT METHOD FLAG = 'A'         *
      *   PAY 70% OF APC RATE                                       *
      *   11/05/2018 - NEW FOR CY 2019; 30% REDUCTION OF APC RATE   *
      *   10/22/2019 - AMERICAN HOSPITAL ASSOCIATION ET AL V. AZAR  *
      *    LAWSUIT    REMOVE PMF = 'A' LOGIC EFF. 10/22/2019        *
      *-------------------------------------------------------------*
      *   11/12/2019 - NEW FOR CY 2020; PAYS 40% OF APC RATE        *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = 'A'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * PMF-A-REDUCT-2020
                      END-IF


      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '14' (CT SCAN) *
      *   11/10/2015 - NEW FOR CY 2016; 5% REDUCTION                *
      *   07/15/2016 - NEW FOR CY 2017; 15% REDUCTION               *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '14'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * CT-REDUCT-2017
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '21' OR '23'   *
      *   (X-RAY SV)                                                *
      *   08/11/2016 - NEW FOR CY 2017; 20% REDUCTION FOR FILM XRAY *
      *   10/23/2018 - ADD PAF 23 FOR CY 2019                       *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ('21' OR '23')
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * XRAY-FILM-REDUCT-2017
                      END-IF


      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '22' OR '24'   *
      *   (X-RAY SV)                                                *
      *   07/18/2017 - NEW FOR CY 2018; 07% REDUCTION FOR CRT XRAY  *
      *   10/23/2018 - ADD PAF 24 FOR CY 2019                       *
      *** REDUCTION RATE WILL CHANGE TO 10% FOR CY 2023         *****
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ('22' OR '24')
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * XRAY-CRT-REDUCT-2018
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT BY REDUCED UPDATE RATIO WHEN APPROPRIATE   *
      *   11/13/2009 - NEW FOR CY 2009 (QUALITY)                    *
      *   10/19/2016 - EXCLUDE 603 SERVICES FROM QUALITY REDUCTION  *
      *                (PMT METHOD FLAG = 7 OR 8)                   *
      *   12/02/2019 - (PMT METHOD FLAG = X AND Y)EXCLUDED QUALITY  *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = 'X' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = 'Y'
                         PERFORM 19180-REDUCE-APC-PYMT
                            THRU 19180-REDUCE-APC-PYMT-EXIT
                      END-IF



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 19150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 19150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 19150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 19150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 19150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 19150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF LINES ELIGIBLE FOR DEVICE CREDIT *
      * WHEN THE CLAIM'S TOTAL DEVICE CREDIT IS > $0 AND THE LINE   *
      * HAS PAYMENT ADJUSTMENT FLAG '17'                            *
      * - REVISED DEVICE CREDIT LOGIC FOR APRIL 2016                *
      ***************************************************************
             IF H-CLAIM-DEVCR-AMT > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17'
                COMPUTE H-TOT-DEVCR-PYMTS =
                        H-TOT-DEVCR-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF TERMINATED PROCEDURE LINES       *
      * ELIGIBLE FOR DEVICE OFFSET WHEN PAYER ONLY VALUE CODE QQ    *
      * IS > $0 AND THE LINE HAS PAYMENT ADJUSTMENT FLAG '16'       *
      * (LINE MODIFIER IS 73)                                       *
      * - IMPLEMENTED IN APRIL 2016                                 *
      ***************************************************************
             IF L-PAYER-ONLY-VC-QQ > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16'
                COMPUTE H-TOT-TPDO-PYMTS =
                        H-TOT-TPDO-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE LINE CHARGES OF PASS-THROUGH DEVICE LINES        *
      * ASSOCIATED WITH PAYER ONLY VALUE CODES QN AND QO            *
      * - LINES WITH PAF '12' RECEIVE OFFSET IN VALUE CODE QN       *
      * - LINES WITH PAF '13' RECEIVE OFFSET IN VALUE CODE QO       *
      * - LINES WITH PAF '15' RECEIVE OFFSET IN VALUE CODE QP       *
      * NEW FOR CY2016 - 11/13/2015                                 *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
                COMPUTE H-QN-TOT-PTD-CHARGES =
                        H-QN-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
                COMPUTE H-QO-TOT-PTD-CHARGES =
                        H-QO-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *         COMPUTE H-QP-TOT-PTD-CHARGES =
      *                 H-QP-TOT-PTD-CHARGES +
      *                 OPPS-SUB-CHRG (LN-SUB)
      *      END-IF.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                PERFORM 19300-COIN-DEDUCT
                   THRU 19300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2009.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                SET W20BD-INDX TO 1
                SEARCH W20BD-ENTRY VARYING W20BD-INDX
                   AT END
                      GO TO 19150-INIT-EXIT
                   WHEN W-2020-BLOOD-HCPCS (W20BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-2020-BLOOD-RANK (W20BD-INDX) TO H-BLOOD-RANK
                     MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                     PERFORM 19375-BLOOD-DEDUCT
                        THRU 19375-BLOOD-DEDUCT-EXIT
                    END-IF.

       19150-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH COMPOSITE          *
      *  ADJUSTMENT FLAG NOT = '00' & POPULATE COMPOSITE APC TABLE  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY COMPOSITE ADJUSTMENT FLAG (CAF) -   *
      *    LOWEST TO HIGHEST FLAG VALUE (01 - NN)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH CAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *  11/12/2008 - LOGIC REVISED FOR CY 2009 TO USE THE          *
      *               COMPOSITE ADJUSTMENT FLAG INSTEAD OF THE      *
      *               PAYMENT ADJUSTMENT FLAG, VARIABLE H-CMP-CAF   *
      *               HOLDS COMPOSITE ADJUSTMENT FLAG, VARIABLE     *
      *               W-CMP-PAF RETAINED AND NOW HOLDS THE CAF      *
      *               (RETAINED TO CONTINUE USE OF EXISTING TABLE)  *
      *                                                             *
      ***************************************************************
       19170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S COMPOSITE ADJUSTMENT FLAG FOR TABLE SEARCH   *
      *-------------------------------------------------------------*
             MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE CAF         *
      *-------------------------------------------------------------*
                PERFORM 19171-SEARCH-CAF
                   THRU 19171-SEARCH-CAF-EXIT.

       19170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       19171-SEARCH-CAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS NOT      *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 19172-ADD-ENTRY
                      THRU 19172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS ALREADY  *
      * IN THE TABLE, UPDATE THE ENTRY                              *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                   PERFORM 19173-UPDATE-ENTRY
                      THRU 19173-UPDATE-ENTRY-EXIT.

       19171-SEARCH-CAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       19172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS COMPOSITE ADJUSTMENT FLAG (CAF) - LOWEST TO HIGHEST CAF *
      *-------------------------------------------------------------*
             PERFORM 19174-STAGE-CMP-ENTRY
                THRU 19174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-CAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-CAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       19172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * COMPOSITE ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE       *
      *                                                             *
      ***************************************************************
       19173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE CAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       19173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER CAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       19174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       19174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       19175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 19175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       19175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      REDUCE APC PAYMENT OF LINES FROM PROVIDERS WITH A      *
      *      SPACE IN THE QUALITY INDICATOR FIELD OF THE OPSF       *
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      *  11/16/2010 - ADDED SI = U (BRACHY) TO LOGIC                *
      *                                                             *
      ***************************************************************
       19180-REDUCE-APC-PYMT.

      *-------------------------------------------------------------*
      *  SPECIFY LINES ELIGIBLE FOR REDUCTION                       *
      *  11/13/2019- QUALITY ADJUSTMENT EXCLUSION FOR NEW TECHNOLOGY*
      *  CATEGORY APC RANGES:                                       *
      *             - 1575-1599 (EFF. 1/1/2016)                     *
      *             - 1901-1906 (EFF. 1/1/2017)                     *
      *             - 1907-1908 (EFF. 1/1/2018)                     *
      *-------------------------------------------------------------*
             IF ( L-PSF-HOSP-QUAL-IND = ' ' )  AND

                (  (OPPS-SRVC-IND (LN-SUB) = ' P')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' R')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' S' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01491' AND
                           OPPS-GRP (LN-SUB) <= '01537') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01575' AND
                           OPPS-GRP (LN-SUB) <= '01585') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01908'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' T' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01539' AND
                           OPPS-GRP (LN-SUB) <= '01574') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01589' AND
                           OPPS-GRP (LN-SUB) <= '01599') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01908'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' U')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' V')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' X')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J1')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J2')  ) THEN

                COMPUTE H-APC-PYMT ROUNDED = H-APC-PYMT * 0.981
                MOVE 11 TO A-RETURN-CODE (LN-SUB)

             END-IF.


       19180-REDUCE-APC-PYMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       19200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   IF W-WINX-LOOKUP
                      MOVE  50  TO A-CLM-RTN-CODE
                   END-IF
                   GO TO 19200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA
      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 19210-WAGE-LOOKUP.

      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0 OR NOT NUMERIC             *
      *   *AND* NOT ON RURAL FLOOR LOOKUP                           *
      ***************************************************************

             IF (H-WINX = 0 OR H-WINX NOT NUMERIC) AND
                 W-WINX-LOOKUP THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       19200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       19210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE MEETS THE CRITERIA:       *
      *  - MUST NOT BE AFTER THE LATEST WAGE INDEX EFFECTIVE DATE   *
      *    THAT CAN BE USED BY THE CLAIM                            *
      *  - EXCEPT FOR INDIAN HEALTH PROVIDERS (CBSAS 98 AND 99),    *
      *    MUST BE WITHIN THE CLAIM'S CALENDAR YEAR                 *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD / LATEST         *
      *   EFFECTIVE DATE FOR THE CBSA)                              *
      ***************************************************************
             MOVE WCW-DTCD (W-SUB3) TO W-WCW-DTCD.

             IF W-WCW-DTCD NOT > WCD-DTCD (WCD-SUB) AND

                ( (WCD-DATE (W-WCW-DTCD) >= W-CY-BEGIN-DATE AND
                   WCD-DATE (W-WCW-DTCD) <= W-CY-END-DATE AND
                   H-PSF-CBSA NOT = '   98' AND
                   H-PSF-CBSA NOT = '   99') OR

                  (H-PSF-CBSA = '   98' OR
                   H-PSF-CBSA = '   99') )


      *-------------------------------------------------------------*
      *   THIS LOOKS UP PROVIDERS RURAL FLOOR IN THIRD COLUMN OF    *
      *   WAGE INDEX TABLE                                          *
      *   IF FOUND, STORE RURAL WAGE INDEX  RESULT IN H-WINX        *
      *   (RURAL FLOOR LOOKUP IS PERFORMED BEFORE CBSA WAGE INDEX   *
      *    LOOKUP)                                                  *
      *-------------------------------------------------------------*
                IF W-FLOOR-LOOKUP
                      MOVE WCW-WINX3 (W-SUB3) TO H-WINX
                END-IF
      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *   *ONLY VALID FOR WAGE INDEX LOOKUP, NOT RURAL FLOOR*       *
      *   IF WAGE INDEX > FLOOR, OVERWRITE H-WINX                   *
      *-------------------------------------------------------------*
                IF W-WINX-LOOKUP
                   IF L-PSF-SPEC-PYMT-IND = 'Y' THEN
                      IF WCW-WINX2 (W-SUB3) > H-WINX THEN
                         MOVE WCW-WINX2 (W-SUB3) TO H-WINX
                      END-IF
      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *   IF WAGE INDEX > FLOOR  -STORE  RESULT IN H-WINX.          *
      *-------------------------------------------------------------*
                   ELSE
                      IF WCW-WINX1 (W-SUB3) > H-WINX
                         MOVE WCW-WINX1 (W-SUB3) TO H-WINX
                      END-IF
                   END-IF
                END-IF

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE DID NOT MEET THE CRITERIA *
      *  - AFTER THE LATEST EFFECTIVE DATE THE CLAIM CAN USE -OR-   *
      *  - NOT WITHIN THE CLAIM'S CALENDAR YEAR AND NOT IN CBSA     *
      *    98 OR 99                                                 *
      *  GO TO THE PRIOR RECORD FOR THIS CBSA WITH AN EARLIER DATE  *
      *  IN THE CBSA WAGE INDEX TABLE.                              *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *  AGAIN AND REPEAT THE PROCESS
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 19210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      * >10-28-2014 ONLY VALID FOR WAGE INDEX PASS, NOT RURAL FLOOR *
      *-------------------------------------------------------------*
                ELSE

                   IF W-WINX-LOOKUP
                      MOVE 0 TO H-WINX
                END-IF
             END-IF.

       19210-WAGE-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       19250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 19250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       19250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       19300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 19350-STAGE-ENTRY
                THRU 19350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX      TO W-WINX (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       19300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       19350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       19350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       19375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 19385-STAGE-ENTRY
                THRU 19385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX     TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       19375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       19385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       19385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PAYMENTS, DEDUCTIBLES, REIM., & COINSURANCE,*
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       19400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 19400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 19550-CALC-STANDARD
                   THRU 19550-CALC-STANDARD-EXIT
             ELSE
                GO TO 19400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRUG COINSURANCE TABLE FOR LATER PROCESSING        *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET BLOOD-FLAG WHEN SERVICE INDICATOR = R (BLOOD)        *
      *  - EXCLUDE PACKAGED BLOOD DEDUCTIBLE LINES & SECTION 603    *
      *    SERVICE LINES                                            *
      *  - ADDED PMF ='X' AND 'Y' TO BE EXCLUDED SECTION 603 SV LINE*
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30 AND
                NOT PKG-BLD-DED-LINE AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X' AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '8' AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y'
                PERFORM 19450-ADJ-PROC-COIN
                   THRU 19450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 19500-ADJ-CHRGS
                THRU 19500-ADJ-CHRGS-EXIT.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

                COMPUTE A-DEVICE-CREDIT-QD =
                        A-DEVICE-CREDIT-QD + H-LINE-DEVCR-AMT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 15840-PROCESS-TYPE2     *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)

               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       19400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      POPULATE COINSURANCE CAP ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: BLOOD LINE                              *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY BLOOD LINE         *
      *                                                             *
      * COINSURANCE RECORD COMBINATIONS:                            *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       BLOOD ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT   *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO BLOOD ADMINISTERED ON THE   *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH BLOOD ADMINISTERED ON THE      *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = R =>               *
      *       BLOOD ADMINSTERED ON THE DATE OF SERVICE              *
      *                                                             *
      ***************************************************************
       19450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                PERFORM 19455-SEARCH-KEY
                   THRU 19455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = R LINES (BLOOD)                                *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET BLOOD-FLAG TO INDICATE BLOOD LINE                       *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO BLOOD-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                   PERFORM 19455-SEARCH-KEY
                      THRU 19455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY BLOOD LINE)*
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = R       *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW BLOOD COINSURANCE ENTRY             *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 19475-STAGE-DCP-ENTRY
                      THRU 19475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, BLOOD                                        *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       19450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COINSURANCE CAP ROLL-UP TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       19455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH COINSURANCE CAP TABLE STARTING AT ENTRY #1           *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 19460-ADD-ENTRY
                      THRU 19460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 19465-UPDATE-ENTRY
                      THRU 19465-UPDATE-ENTRY-EXIT.

       19455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE COINSURANCE TABLE                                       *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       19460-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COINSURANCE CAP TABLE ENTRY         *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 19475-STAGE-DCP-ENTRY
                THRU 19475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, BLOOD                                        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       19460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COINSURANCE RECORD WITH THE SAME        *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       19465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR BLOOD LINES - ACCUMULATE DAY'S TOTAL BLOOD COIN DUE     *
      * -REMOVE ' G' & ' K'                                         *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A BLOOD LINE, UPDATE THE RECORD   *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 19485-REPLACE-TYPE1
                     THRU 19485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 19480-RANK-COIN
                     THRU 19480-RANK-COIN-EXIT.

       19465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COINSURANCE RECORD WITH A HIGHER          *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       19475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       19475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST ACTUAL     *
      * COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE           *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *  CHANGED TO ACTUAL FROM NATIONAL COINSURANCE FOR 2018       *
      ***************************************************************
       19480-RANK-COIN.

             IF H-NEW-COIN > W-DCP-COIN1 (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       19480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = R        *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = BLOOD LINE NEW COINSURANCE AMOUNT(S)              *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       19485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       19485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 15600-ADJ-CHRG-OUTL.)                     *
      *                                                             *
      ***************************************************************
       19500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
      * 12/18/2009 - ADD SIS R & U, WHICH ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P' OR ' R' OR ' U' OR 'J1' OR 'J2')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                AND NOT PKG-BLD-DED-LINE
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       19500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    & TAKE PT DEVICE OFFSET WHEN APPLICABLE                  *
      * 5. CALCULATE AND APPLY DEVICE CREDIT                        *
      *                                                             *
      ***************************************************************
       19550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 19655-SET-BD-HCPCS-FLAG
                THRU 19655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      *   FLAG LINE IF ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND CLAIM  *
      *   HAS A COMPREHENSIVE APC; TREAT AS PACKAGED LINE           *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             ELSE
                  MOVE 'N' TO PKG-BLD-DED-LINE-FLAG
             END-IF.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).


      ***************************************************************
      * CALCULATE DEVICE CREDIT FOR ELIGIBLE LINE(S)                *
      *-------------------------------------------------------------*
      * 02/09/2016- REVISED LOGIC IMPLEMENTED IN APRIL 2016         *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-CLAIM-DEVCR-AMT > 0 AND
                H-TOT-DEVCR-PYMTS > 0
                PERFORM 19550-DEVICE-CREDIT
                   THRU 19550-DEVICE-CREDIT-EXIT.


      ***************************************************************
      * CALCULATE DEVICE OFFSET FOR ELIGIBLE TERMINATED PROCEDURE   *
      * LINES AND REDUCE THE APC PAYMENT BY THE DEVICE OFFSET AMOUNT*
      *-------------------------------------------------------------*
      * 02/09/2016- NEW LOGIC IMPLEMENTED IN APRIL 2016             *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16' AND
                L-PAYER-ONLY-VC-QQ > 0 AND
                H-TOT-TPDO-PYMTS > 0
                PERFORM 19550-TERM-PROC-DEV-OFF
                   THRU 19550-TERM-PROC-DEV-OFF-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, X, J1, OR J2 LINES   *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      * 10/26/2016 - STOPPED PERFORMING PHP OUTLIER CAPPING LOGIC   *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X' OR
                 'J1' OR 'J2') THEN
                  PERFORM 19550-SCH-ADJ
                     THRU 19550-SCH-ADJ-EXIT
                  PERFORM 19560-CALC-BENE-DEDUCT
                     THRU 19560-CALC-BENE-DEDUCT-EXIT


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (PT DEVICE) LINES, PAYMENT IND.*
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      *-------------------------------------------------------------*
      * 01/01/2009 - BRACHYTHERAPY SERVICES ADDED FOR CY 2009       *
      * 11/15/2009 - BRACHYTHERAPY SERVICES (SI=U) REMOVED CY 2010  *
      *            - THERAPEUTIC RADIOPHARMS' SI NOT 'H' FOR CY2010 *
      * 08/11/2010 - NEW PASS-THROUGH DEVICE OFFSET LOGIC ADDED IN  *
      *              PARAGRAPH 10555-CALC-H-STANDARD                *
      * 11/16/2015 - REVISED PT-DEVICE LOGIC: 15555-CALC-H-STANDARD *
      ***************************************************************
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' H') THEN
                 IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                       OPPS-PYMT-IND (LN-SUB) = ' 6')
                   PERFORM 19555-CALC-H-STANDARD
                      THRU 19555-CALC-H-STANDARD-EXIT
                   PERFORM 19560-CALC-BENE-DEDUCT
                      THRU 19560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 19550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = R & U LINES; THE PMT. IND.       *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      * 11/15/2009 - ADDED BRACHYTHERAPY SERVICES (SI=U) FOR CY2010 *
      *              THERAPEUTIC RADIOPHARMS' SI=K FOR CY 2010      *
      * 11/16/2009 - ADD LOGIC TO ADJUST PT CONTRAST AGENT HCPCS    *
      *              LINE PAYMENT BY OFFSET                         *
      * 05/10/2016 - CALCULATE BLOOD DEDUCTIBLE & LINE PAYMENT FOR  *
      *              BLOOD DEDUCTIBLE LINES ON COMPREHEMSIVE APC    *
      *              CLAIMS (THESE LINES WERE PREVIOUSLY PACKAGED)  *
      *            - ADD LOGIC TO EXEMPT BLOOD DEDUCTIBLE LINES ON  *
      *              COMPREHENSIVE APC CLAIMS FROM REIM, COIN, &    *
      *              NON-BLOOD DEDUCTIBLE CALCS.                    *
      * 10/21/2016 - NO LONGER CALCULATE PAYMENT FOR SI G & K LINES *
      *              (DRUGS) IN PRICER; NOW CALCULATED IN FISS      *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 19550-CALC-RU
                         THRU 19550-CALC-RU-EXIT

                      IF PKG-BLD-DED-LINE
                         NEXT SENTENCE
                      END-IF

                      PERFORM 19560-CALC-BENE-DEDUCT
                         THRU 19560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 19550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      * 11/12/2008 - BRACHYTHERAPY SOURCE'S STATUS INDICATOR = ' U' *
      *              EFFECTIVE 1/1/2009                             *
      *                                                             *
      * 11/16/2009 - REMOVED LOGIC FOR THERAPEUTIC RADIOPHARMS &    *
      *              BRACHYTHERAPY SOURCES B/C THESE ARE NOT PAID   *
      *              AT COST FOR CY 2010                            *
      *                                                             *
      * 04/11/2011 - ADDED LOGIC TO PREVENT LINES WITH PAFS 9 OR 10 *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      * 05/13/2016 - ADDED LOGIC FOR BLOOD DEDUCTIBLE LINES ON A    *
      *              COMPREHENSIVE APC CLAIM (ZERO OUT REIM, COIN,  *
      *              & NON-BLOOD DEDUCTIBLE)                        *
      *                                                             *
      * 10/23/2018 - ADDED LOGIC TO PREVENT LINES W/PAFS 23  OR 24  *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * FOR BLOOD DEDUCTIBLE LINES ON A COMPREHENSIVE APC CLAIM:    *
      * SET REIMBURSEMENT, COINSURANCE, & DEDUCTIBLE AMOUNTS TO $0  *
      *-------------------------------------------------------------*
             IF PKG-BLD-DED-LINE
                MOVE 0 TO H-LITEM-REIM
                          H-TOTAL-LN-DEDUCT
                          H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 19550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE REIMBURSEMENT AND SET COINSURANCE AMOUNTS TO $0   *
      * FOR LINES WITH A PAF= 9 OR 10 OR 23 OR 24                   *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 9' OR '10' OR '23'
                                                OR '24')
                COMPUTE H-LITEM-REIM ROUNDED =
                   H-LITEM-PYMT - H-TOTAL-LN-DEDUCT
                MOVE 0 TO H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 19550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                  H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX).

      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * FOR SECTION 603 SERVICES -                                  *
      * SET MIN, MAX, AND REDUCED COINSURANCE TO PSF STANDARD       *
      * FOR LINES WITH A PMF= 7 OR 8 OR X OR Y                      *
      *-------------------------------------------------------------*
             IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X' OR
                OPPS-SITE-SRVC-FLAG (LN-SUB) = '8' OR
                OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y'
                COMPUTE H-MIN-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                COMPUTE H-MAX-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                MOVE 0  TO H-RED-COIN

                GO TO 19550-CALC-STANDARD-EXIT
             END-IF.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DEVICES, BRACHYTHERAPY, & BLOOD                             *
      * (SI = H LINES HAVE A MIN-COIN = 0, WON'T ENTER LOGIC)       *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) =
                  ' H' OR ' R' OR ' U'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       19550-CALC-STANDARD-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE LINE'S DEVICE CREDIT AMOUNT                   *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - REVISED LOGIC IMPLEMENTED APRIL 2016           *
      *                                                             *
      ***************************************************************
       19550-DEVICE-CREDIT.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE CREDIT     *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-DEVCR-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-DEVCR-PYMTS.

           COMPUTE H-LINE-DEVCR-AMT ROUNDED =
                   H-CLAIM-DEVCR-AMT * H-LINE-DEVCR-PYMT-RATE.

       19550-DEVICE-CREDIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE TERMINATED PROCEDURE LINE'S DEVICE OFFSET     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - NEW FOR CY 2016 (APRIL IMPLEMENTATION)         *
      *                                                             *
      ***************************************************************
       19550-TERM-PROC-DEV-OFF.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE OFFSET     *
      * FOR TERMINATED PROCEDURES                                   *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-TPDO-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-TPDO-PYMTS.

           COMPUTE H-LINE-TPDO-AMT ROUNDED =
                   L-PAYER-ONLY-VC-QQ * H-LINE-TPDO-PYMT-RATE.

      *-------------------------------------------------------------*
      * ADJUST THE BASE APC PAYMENT BY THE DEVICE OFFSET            *
      *-------------------------------------------------------------*
           IF W-APC-PYMT (W-LP-INDX) >= H-LINE-TPDO-AMT
              COMPUTE W-APC-PYMT (W-LP-INDX) ROUNDED =
                      W-APC-PYMT (W-LP-INDX) - H-LINE-TPDO-AMT
           ELSE
              MOVE 0 TO W-APC-PYMT (W-LP-INDX)
           END-IF.

       19550-TERM-PROC-DEV-OFF-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *        FOR LINES WITH A SI OF S, V, T, P, X, R, OR U        *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA OR THE     *
      *   L-PSF-PYMT-CBSA MUST BE A VALUE OF                        *
      *   '   01' THRU '   99' AND THE L-PSF-PROV-TYPE              *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2017: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      * 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES (SI=R)     *
      *              ADDED TO LOGIC.  BRACHY LINES NOT PROCESSED IN *
      *              PARAGRAPH & NOW HAVE A SI = U, SI = K LOGIC    *
      *              REMOVED FROM THIS PARAGRAPH.                   *
      * 05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD    *
      *              DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.     *
      *              FIX EFFECTIVE RETROACTIVE TO 01/01/2009.       *
      * 11/17/2009 - BRACHYTHERAPY LINES NOW PROCESSED IN THIS      *
      *              PARAGRAPH FOR CY 2010 (SI=U), DO NOT RECEIVE   *
      *              WAGE ADJUSTMENT                                *
      * 05/09/2011 - REVISED LOGIC TO EXCLUDE BILL TYPE 14X FROM    *
      *              RECEIVING THE SCH ADD-ON                       *
      * 02/07/2012 - REPLACE BILL14X-FLAG WITH CONDITION NAME       *
      *              BILL-TYPE-14X                                  *
      * 01/27/2014 - WHEN APPLICABLE, SUBTRACT DEVICE CREDIT        *
      *              AMOUNT FROM LINE ITEM PAYMENT                  *
      * 10/21/2016 - EXCLUDE SECTION 603 SERVICE LINES FROM SCH ADJ *
      * 06/12/2017 - IF THE GEOGRAPHIC, WAGE INDEX, OR PAYMENT CBSA *
      *              IS RURAL, APPLY THE RURAL SCH ADJ. TO THE LINE *
      *              PAYMENT. ADDED L-PSF-PYMT-CBSA CY2017          *
      ***************************************************************
       19550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.
             MOVE L-PSF-PYMT-CBSA TO PYMT-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      *   - SECTION 603 SERVICES EXCLUDED FROM THE SCH ADJUSTMENT   *
      ***************************************************************

             IF (RURAL-GEO OR RURAL-WI OR RURAL-PYMT) AND
                (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22') AND
                (NOT BILL-TYPE-14X) AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7') AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = 'X') AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8') AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = 'Y')
      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*

                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      ***************************************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = R (BLOOD) OR U (BRACHY) LINES ARE NOT WAGE-ADJUSTED    *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U'
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.
      *-------------------------------------------------------------*
      * REDUCE ADJUSTED APC PAYMENT BY DEVICE CREDIT IF APPLICABLE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-LINE-DEVCR-AMT > 0
                IF H-LITEM-PYMT >= H-LINE-DEVCR-AMT
                   COMPUTE H-LITEM-PYMT ROUNDED =
                           H-LITEM-PYMT - H-LINE-DEVCR-AMT
                ELSE
                   MOVE 0 TO H-LITEM-PYMT
                END-IF
             END-IF.


       19550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = R & U LINES:         *
      *   - APC PAYMENT FOR BLOOD LINES (SI = R)                    *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = U LINES                      *
      *   - SCH ADJUSTMENT APPLIED TO BLOOD & BRACHY LINES          *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      * - 11/12/2008 - FOR CY 2009, BRACHYS NOT PROCESSED IN THIS   *
      *   PARAGRAPH; BRACHY LINES ASSIGNED A NEW SI OF ' U'         *
      * - 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES HAVE A   *
      *   SI = R                                                    *
      * - 12/05/2008 - MODIFIED LOGIC TO SEND BLOOD LINES WITHOUT   *
      *   A PMT ADJ FLAG = 5 OR 6 TO THE SCH ADJUSTMENT PARAGRAPH,  *
      *   INCLUDED SI = R IN THE BLOOD IDENTIFICATION LOGIC         *
      * - 11/15/2009 - BRACHYTHERPY SERVICES (SI = U) & THERAPEUTIC *
      *   RADIOPHARMS (SI = K) SENT TO THIS PARAGRAPH FOR CY 2010,  *
      *   LOGIC ALTERED TO PROCESS SI = U (RECEIVE REGULAR APC PMT) *
      * - 11/17/2009 - SEND BRACHYTHERAPY LINES TO 10550-SCH-ADJ TO *
      *   MAKE ELIGIBLE FOR SCH ADJUSTMENT, NOT WAGE ADJUSTED       *
      * - 05/10/2016 - ADDED LOGIC FOR SPECIAL HANDLING OF BLOOD    *
      *   DEDUCTIBLE LINES ON CLAIMS WITH A COMPREHENSIVE APC       *
      * - 11/2016 - REMOVED LOGIC FOR SI = G & K LINES (DRUGS)      *
      *                                                             *
      ***************************************************************
       19550-CALC-RU.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 19550-SET-BLOOD-FRACTION
                     THRU 19550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 19550-ADJ-BLOOD-COST
                     THRU 19550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 19550-SCH-ADJ
                     THRU 19550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * CHANGE THE PAYMENT OF THE BLOOD DEDUCTIBLE LINE ON THE SAME *
      * CLAIM AS A COMPREHENSIVE APC TO THE BLOOD DEDUCTIBLE AMOUNT *
      *-------------------------------------------------------------*
                  IF PKG-BLD-DED-LINE
                      MOVE H-LN-BLOOD-DEDUCT TO H-LITEM-PYMT
                  END-IF

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE, BUT PAF = 5 OR 6           *
      * (BLOOD PROCESSING AND PRODUCT BILLED TOGETHER)              *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 19550-ADJ-PLATE-COST
                      THRU 19550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 19550-SCH-ADJ
                      THRU 19550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE AND PAF NOT EQUAL TO 5 OR 6 *
      * (ONLY BLOOD PRODUCT BILLED)                                 *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 12/05/2008 - 7550-SCH-ADJ PERFORM ADDED FOR BLOOD LINES     *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 19550-SCH-ADJ
                      THRU 19550-SCH-ADJ-EXIT
                ELSE
                   IF OPPS-SRVC-IND (LN-SUB) = ' U'
                      PERFORM 19550-SCH-ADJ
                         THRU 19550-SCH-ADJ-EXIT
                   END-IF
                END-IF
             END-IF
             END-IF.

       19550-CALC-RU-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       19550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       19550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       19550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       19550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       19550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       19550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *           CALCULATE PAYMENT FOR PAID AT COST LINES          *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 08-11-2010 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED       *
      * 11-17-2015 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED AGAIN *
      * 08-18-2016 - USE DEVICE CCR WHEN AVAILABLE                  *
      *                                                             *
      ***************************************************************
       19555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST - "PAID AT COST"         *
      * (IF NO DEVICE CCR USE HOSPITAL CCR)                         *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

              IF L-PSF-DEVICE-CCR = 0
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG *  L-PSF-OPCOST-RATIO)
              ELSE
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG * L-PSF-DEVICE-CCR)
              END-IF.

      *-------------------------------------------------------------*
      * FOR PASS-THROUGH DEVICE LINE WITH AN ASSOCIATED OFFSET,     *
      * APPLY THE OFFSET (INDICATED BY PAF = '12' OR '13' OR '15'   *
      * (NOT CURRENTLY USING PAF '15')                              *
      *-------------------------------------------------------------*
              IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12' OR
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13' OR
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
                 PERFORM 19556-CALC-PTD-OFFSET
                    THRU 19556-CALC-PTD-OFFSET-EXIT
              END-IF.

      *-------------------------------------------------------------*
      * CAPTURE PAYMENT AMOUNT                                      *
      *-------------------------------------------------------------*
             IF T-LITEM-PYMT < 0 THEN
                MOVE 0 TO H-LITEM-PYMT
             ELSE
                MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

       19555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *   REDUCE LINE ITEM PAYMENTS OF PASS-THROUGH DEVICES THAT    *
      * HAVE AN ASSOCIATED PROCEDURE ON THE CLAIM BY THE PROCEDURE  *
      *                WAGE-ADJUSTED OFFSET AMOUNT                  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ** EFFECTIVE 11/13/2015 - REVISED PT DEVICE OFFSET LOGIC    *
      *                                                             *
      ***************************************************************
       19556-CALC-PTD-OFFSET.

      *-------------------------------------------------------------*
      * DETERMINE WHICH VARIABLES TO USE IN CALCULATIONS            *
      *-------------------------------------------------------------*
            INITIALIZE H-TOT-PTD-CHARGES
                       H-WA-PTD-OFFSET.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
               MOVE H-QN-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QN-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
               MOVE H-QO-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QO-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *     IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *        MOVE H-QP-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
      *        MOVE H-QP-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
      *     END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHAT % OF THE OFFSET WILL BE APPLIED              *
      *-------------------------------------------------------------*
            IF H-TOT-PTD-CHARGES > 0
               COMPUTE W-PTDO-CHRG-RATE ROUNDED =
                       H-SUB-CHRG / H-TOT-PTD-CHARGES
            ELSE
               GO TO 19556-CALC-PTD-OFFSET-EXIT
            END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE TAKEN                     *
      *-------------------------------------------------------------*
            COMPUTE W-PTDO-LINE-OFFSET ROUNDED =
                    W-PTDO-CHRG-RATE *
                    H-WA-PTD-OFFSET.

      *-------------------------------------------------------------*
      * SUBTRACT THE OFFSET AMOUNT FROM THE LINE PAYMENT            *
      *-------------------------------------------------------------*
            IF W-PTDO-LINE-OFFSET <= T-LITEM-PYMT
               COMPUTE T-LITEM-PYMT ROUNDED =
                       T-LITEM-PYMT - W-PTDO-LINE-OFFSET
            ELSE
               MOVE 0 TO T-LITEM-PYMT
            END-IF.


       19556-CALC-PTD-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       19560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * LINES INELIGIBLE FOR DEDUCTIBLE SKIP DEDUCTIBLE CALCULATION *
      * EFF. 7/1/2009 - CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      * ASSIGNED A PAF = ' 4'                                       *
      * - 04/11/2011 - ADDED PAF 9 FOR SERVICES WHERE THE           *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *   (ADDED FOR PREVENTIVE SERVICES WAIVER IN CY 2011)         *
      * - 10/23/2018 - ADDED PAF 23 & 24  FOR SERVICES WHERE THE    *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 4' OR ' 9' OR '23'
                                                OR '24')
                GO TO 19560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       19560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      * - 11/12/2008: FOR CY 2009, BRACHYS SI = U AND BLOOD SI = R  *
      *   BRACHY INELIGIBLE FOR OUTLIER, BLOOD ELIGIBLE FOR OUTLIER *
      *                                                             *
      * - 12/05/2008: ADDED SI = K TO LIST OF SIS INELIGIBLE FOR    *
      *   OUTLIER (BRACHYS & BLOOD NO LONGER HAVE SI = K)           *
      *                                                             *
      * - 11/17/2009: REMOVED U FROM LIST OF SIS INELIGIBLE FOR     *
      *   OUTLIER; BRACHYS NOW ELIGIBLE B/C NOT PAID AT COST CY 2010*
      *                                                             *
      * - 12/16/2009: ADDED SIS R AND U TO LOGIC THAT DISTRIBUTES   *
      *   PACKAGED CHARGES TO PAYABLE LINES. V2010.1.2              *
      *                                                             *
      * - 11/04/2011: MODIFIED LOGIC TO APPLY THE PHP CAP ONLY TO   *
      *   PHP CMHC LINES, NOT PHP HOSPITAL LINES PER POLICY'S       *
      *   INSTRUCTIONS                                              *
      *                                                             *
      * - 11/17/2015: MODIFIED LOGIC TO STOP ACCOUNTING FOR         *
      *   PASS-THROUGH DEVICE PAYMENTS AND CHARGES IN ASSOCIATED    *
      *   PROCEDURE'S OUTLIER CALCULATION.  ADDED STATUS INDICATOR  *
      *   'J2' AS ELIGIBLE FOR OUTLIER AND TO RECEIVED PACKAGED     *
      *   CHARGES                                                   *
      *                                                             *
      * - 05/10/2016: ADDED LOGIC TO EXCLUDE LINES ELIGIBLE FOR THE *
      *   BLOOD DEDUCTIBLE AND ON A CLAIM WITH A COMPREHENSIVE APC  *
      *   FROM THE OUTLIER PAYMENT                                  *
      *                                                             *
      * - 10/21/2016: ADDED LOGIC TO EXCLUDE SECTION 603 SERVICE    *
      *   LINES FROM THE OUTLIER PAYMENT (PMF = 7 OR 8)             *
      *                                                             *
      ***************************************************************
       19600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * SERVICE LINES NOT ELIGIBLE FOR AN OUTLIER PAYMENT:          *
      *   DEVICES, PACKAGED, PACKAGED AS PART OF DRUG ADMIN, AND    *
      *   SECTION 603 SERVICES                                      *
      *-------------------------------------------------------------*
      * 11/12/2008 - BRACHY (SI=U) ADDED TO LIST                    *
      * 12/05/2008 - SI K ADDED TO THE LIST                         *
      * 11/16/2009 - REMOVED PAF=2 FROM BRACHY (SI=U) CRITERIA      *
      * 11/17/2009 - REMOVE SI=U, BRACHYS ARE ELIGIBLE FOR OUTLIER  *
      * 07/26/2016 - REMOVE SI=G SI=K                               *
      * 10/21/2016 - SECTION ADDED 603 SERVICES (PMF = 7 OR 8)      *
      * 12/02/2019 - SECTION ADDED 603 SERVICES (PMF = X OR Y)      *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' H' OR ' N') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y')
                   GO TO 19600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * BLOOD LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND ON A      *
      * CLAIM WITH A COMPREHENSIVE APC NOT ELIGIBLE FOR OUTLIER     *
      *-------------------------------------------------------------*
      * 05/10/2016 - NEW FOR JULY 2016                              *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  GO TO 19600-ADJ-CHRG-OUTL-EXIT
             END-IF.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                           ' X' OR ' P' OR ' R' OR
                                           ' U' OR 'J1' OR 'J2') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                          ' X' OR ' P' OR ' R' OR
                                          ' U' OR 'J1' OR 'J2') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A COMPOSITE ADJ.     *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 01 - NN...) ARE ACCUMULATED BY COMPOSITE            *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME        *
      * (PAYABLE) LINE'S CHARGES.                                   *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2007 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      * 11/12/2008 - CHANGED LOGIC TO USE THE COMPOSITE ADJUSTMENT  *
      *              FLAG INSTEAD OF THE PAYMENT ADJUSTMENT FLAG    *
      *              VALUES 91 - 99 TO ID PRIME COMPOSITE LINES     *
      ***************************************************************

      *-------------------------------------------------------------*
      * COMPOSITE ADJUSTMENT FLAG > 0 INDICATES COMPOSITE APC       *
      *-------------------------------------------------------------*
           IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = '00'

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.


      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD                          *
      *   (ALWAYS USE THE PHP "CAP" APC'S WAGE ADJ PMT FOR PHP LINES*
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED BECAUSE PAYMENTS MAY BE ADJUSTED FOR     *
      *              PASS-THROUGH DEVICES                           *
      * ??/??/2008 - NEW FOR CY 2009 - ALWAYS USE THE PHP "CAP"     *
      *              APC'S WAGE ADJ "CAP" PMT FOR PHP LINES (SI=P)  *
      * 11/04/2011 - ONLY APPLY PHP "CAP" TO CMHC LINES; PER        *
      *              POLICY'S INSTRUCTIONS PHP HOSPITAL LINES ARE   *
      *              NOT CAPPED.                                    *
      * 11/17/2015 - CONTINUE TO USE THIS LOGIC EVEN THOUGH PAYMENTS*
      *              ARE NO LONGER ADJUSTED FOR PT DEVICES          *
      * 10/26/2016 - DISABLED CMHC PHP PMT CAP BECAUSE ALL PHP CMHCS*
      *              USE THE SAME APC EFFECTIVE JANUARY 2017        *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL.


      ***************************************************************
      *                                                             *
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      * -NEW FOR JANUARY 2009                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE PHP "CAP" APC'S LINE PAYMENT                        *
      *                                                             *
      * -NEW FOR JANUARY 2017                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE SAME PHP APC (NO NEED TO CAP PMT)                   *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      * (CMHC PROVIDERS ONLY PROCESS PARTIAL HOSPITALIZATION LINES) *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT

      ***************************************************************
      *     ADD LOGIC TO PREVENT NEGATIVE OUTLIER PAYMENT           *
      ***************************************************************
                   IF H-LITEM-OUTL-PYMT < 0
                      MOVE 0 TO H-LITEM-OUTL-PYMT
                   END-IF


      *-------------------------------------------------------------*
      *     FOR CMHC PROVIDERS THAT ARE SUBJECT TO THE OUTLIER CAP, *
      *     ACCUMULATE CLAIM PAYMENT AND OUTLIER TOTALS             *
      * 12/02/2019 - ADDED PMF = 'Z'                                *
      *-------------------------------------------------------------*
                   IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '0' OR 'Z'
                        COMPUTE H-CMHC-PYMT-TOTAL =
                          H-CMHC-PYMT-TOTAL + H-LITEM-PYMT-OUTL

                        COMPUTE H-CMHC-OUTL-TOTAL =
                          H-CMHC-OUTL-TOTAL + H-LITEM-OUTL-PYMT
                   END-IF

      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE

                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 5075)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT
                  END-IF
               END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT.


      *-------------------------------------------------------------*
      * LINES THAT ARE NOT ELIGIBLE FOR AN OUTLIER PAYMENT BECAUSE  *
      * OUTLIER CAP WAS MET BEFORE THIS CLAIM WAS PROCESSED -       *
      * ZERO OUT LINE OUTLIER PAYMENT & REMOVE FROM CLAIM TOTAL     *
      * 8/21/16 -MOVE 2 TO RETURN CODE, IF FLAG = 6 & OUTL PYMT > 0 *
      *-------------------------------------------------------------*
             IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6')
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT
                MOVE 02 TO A-CLM-RTN-CODE.


       19600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *               CAP CMHC TOTAL OUTLIER PAYMENTS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      * FOR CMHC CLAIMS ONLY, DO THE FOLLOWING:                     *
      *                                                             *
      * - DETERMINE IF THE TOTAL CLAIM OUTLIER PAYMENT ELIGIBLE     *
      *   FOR CAPPING IS > $0                                       *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS PAYMENTS INCLUDING THE *
      *   CURRENT CLAIM'S PAYMENTS                                  *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS OUTLIER PAYMENTS       *
      *   INCLUDING THE CURRENT CLAIM'S OUTLIER PAYMENTS            *
      * - CALCULATE THE CURRENT OUTLIER PERCET                      *
      * - IF THE OUTLIER PERCENT EXCEEDS THE CAP:                   *
      *   - SET THE CLAIM OUTLIER TO $0                             *
      *   - SET THE RETURN CODE TO 02                               *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JULY 2017, EFFECTIVE JANUARY 2017                 *
      *                                                             *
      ***************************************************************
       19610-CMHC-OUTL-CAP.
             IF ( (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999') ) AND
                H-CMHC-OUTL-TOTAL > 0

      *-------------------------------------------------------------*
      *            CALCULATE PROVIDER'S TOTAL PAYMENTS              *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-PYMT-TOTAL =  H-CMHC-PYMT-TOTAL +
                        L-PRIOR-PYMT-TOTAL

      *-------------------------------------------------------------*
      *       CALCULATE PROVIDER'S TOTAL OUTLIER PAYMENTS           *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTL-TOTAL =  H-CMHC-OUTL-TOTAL +
                        L-PRIOR-OUTL-TOTAL

      *-------------------------------------------------------------*
      *                 CALCULATE OUTLIER PERCENT                   *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTLIER-PCT ROUNDED =
                   H-CMHC-OUTL-TOTAL / H-CMHC-PYMT-TOTAL

      *-------------------------------------------------------------*
      *                     APPLY OUTLIER CAP                       *
      *-------------------------------------------------------------*
                IF H-CMHC-OUTLIER-PCT > CMHC-OUTL-CAP-PCT
                   MOVE 0 TO H-OUTLIER-PYMT
                   MOVE 02 TO A-CLM-RTN-CODE
                END-IF
             END-IF.

       19610-CMHC-OUTL-CAP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 19550-CALC-RU &        *
      *      19550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES        *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       19655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9010' OR
                                    'P9021' OR
                                    'P9051' OR
                                    'P9016' OR
                                    'P9038' OR
                                    'P9056' OR
                                    'P9057' OR
                                    'P9058' OR
                                    'P9040' OR
                                    'P9054' OR
                                    'P9039' OR
                                    'P9022'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       19655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *        PROCESS COINSURANCE CAP ROLL-UP TABLE RECORDS        *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE BLOOD LINE COINSURANCE WHEN THE PROCEDURE       *
      *  COINSURANCE AMOUNTS PLUS THE BLOOD COINSURANCE AMOUNT(S)   *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       19800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 19810-PROCESS-TYPE1
                   THRU 19810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 19840-PROCESS-TYPE2
                   THRU 19840-PROCESS-TYPE2-EXIT.

       19800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH BLOOD COINSURANCE, DETERMINE THE  *
      *  % OF TOTAL BLOOD COINSURANCE THAT CAN BE PAID IN ADDITION  *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE BLOOD COINSURANCE CAN BE PAID*
      *  WHEN H-RATIO = 1, ALL OF THE BLOOD COINSURANCE CAN BE PAID *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       19810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * BLOOD WAS ADMINISTERED ON THE DAY                           *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & ACTUAL COINSURANCE OF THE             *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-COIN1 (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL BLOOD COIN THAT CAN BE   *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      * CHANGED NATIONAL COINSURANCE TO ACTUAL COINSURANCE FOR      *
      * CY2018                                                      *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-COIN1 (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S BLOOD COIN CAN BE PAID B/C THE PROCEDURE/ *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL BLOOD COINSURANCE CAN BE PAID WITHIN THE    *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       19810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE BLOOD LINE'S NATIONAL COINSURANCE AMOUNT AND    *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       19840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 BLOOD COIN REC HAS SAME DATE OF SERVICE AS   *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE BLOOD COIN RECORD*
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE BLOOD LINE BY  *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD BLOOD COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT   *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       19840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       19900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       19900-END-PRICE-RTN-EXIT.
           EXIT.




      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 20000 FOR CALENDAR YEAR 2021 PROCESSING        **
      **          SERVICE FROM DATES: 1/1/2021 - 12/31/2021           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE IOCE)      *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  7. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  8. CALCULATE SERVICE LINE PAYMENTS                            *
      *  9. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 10. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 11. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 12. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 13. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, AND COMPOSITE *
      *     CHARGES OF APPLICABLE PROCEDURES.                          *
      *     ALL ADJUSTMENTS ARE DONE FOR OUTLIER DETERMINATION ONLY.   *
      * 14. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 15. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR BLOOD LINES; *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE BLOOD LINE'S REIMBURSEMENT                    *
      * 16. ACCUMULATE CLAIM TOTALS                                    *
      * 17. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       20000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY),  *
      *            DETERMINE CLAIM DEVICE CREDIT AMOUNT               *
      *            (CLAIM LEVEL INITIALIZATION)                       *
      *                                                               *
      *****************************************************************
              PERFORM 20100-INIT
                 THRU 20100-INIT-EXIT.

      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - C-APC-CLAIM-FLAG - COMPREHENSIVE APC ON CLAIM - FOR       *
      *     SPECIAL BLOOD DEDUCTIBLE LINE LOGIC                       *
      *                                                               *
      *****************************************************************
              PERFORM 20125-INIT
                 THRU 20125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.



      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH *
      *            RADIOPHARMACEUTICAL OFFSET, CREATE CONTRAST        *
      *            AGENT PROCEDURE TABLE FOR PASS-THROUGH CONTRAST    *
      *            AGENT OFFSET.                                      *
      *            (LOOP THROUGH THE CLAIM LINES)                     *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY TABLES FOR NEW CLAIM                             *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX    W-BLD-MAX    W-CMP-MAX.

              PERFORM 20150-INIT
                 THRU 20150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      *-------------------------------------------------------------*
      * CALCULATE WAGE-ADJUSTED PASS-THROUGH DEVICE OFFSETS         *
      * (VALUE CODES QN, QO & QP; CLAIM LEVEL)                      *
      * NEW FOR CY2016 - 11/13/2015                                 *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QN > 0
                COMPUTE H-QN-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QN * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QN * .40)
             END-IF.

             IF L-PAYER-ONLY-VC-QO > 0
                COMPUTE H-QO-WA-PTD-OFFSET ROUNDED =
                        ((L-PAYER-ONLY-VC-QO * .60) * H-WINX) +
                        (L-PAYER-ONLY-VC-QO * .40)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF L-PAYER-ONLY-VC-QP > 0
      *         COMPUTE H-QP-WA-PTD-OFFSET ROUNDED =
      *                 ((L-PAYER-ONLY-VC-QP * .60) * H-WINX) +
      *                 (L-PAYER-ONLY-VC-QP * .40)
      *      END-IF.



      *****************************************************************
      *                                                               *
      *   STEP 4 - INITIALIZE W-DCP-MAX                               *
      *   ------                                                      *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, AND MOVE LINE ITEM         *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 20400-CALCULATE
                 THRU 20400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, AND COMPOSITES, AND CALCULATE  *
      *            OUTLIER PAYMENTS                                   *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 20600-ADJ-CHRG-OUTL
                 THRU 20600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.
              PERFORM 20610-CMHC-OUTL-CAP
                 THRU 20610-CMHC-OUTL-CAP-EXIT.

      *****************************************************************
      *                                                               *
      *   STEP 7 - RECALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS*
      *   ------   FOR STATUS INDICATOR R (BLOOD) LINES WHEN THE DAILY*
      *            INPATIENT DEDUCTIBLE CAP IS EXCEEDED.              *
      *            THE COINSURANCE CAP IS APPLIED USING THE WAGE      *
      *            ADJUSTED NATIONAL COINSURANCE OF EACH DAY'S MOST   *
      *            EXPENSIVE PROCEDURE OR VISIT.                      *
      *            (LOOP THROUGH THE COINSURANCE CAP ROLL-UP TABLE)   *
      *                                                               *
      *****************************************************************
                IF BLOOD-FLAG = 'Y'
                   PERFORM 20800-ADJ-STV-REIM
                      THRU 20800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                END-IF.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 20900-END-PRICE-RTN
                 THRU 20900-END-PRICE-RTN-EXIT.

       20000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY DEDUCTIBLE CAP (H-IP-LIMIT)            *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       20100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE FLAGS AND VARIABLES               *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 11/03/2008 - APC33-FLAG REPLACED BY PHP-APC-FLAG            *
      * 11/12/2008 - BRACHY-APC-FLAG REMOVED, NOT USED FOR CY 2009  *
      * 02/09/2009 - PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG ADDED    *
      * 11/16/2009 - RADIOPH-APC-FLAG REMOVED; PTCA-CLAIM-FLAG,     *
      *              PTCA-LINE FLAG ADDED                           *
      * 02/07/2012 - BILL14X-FLAG REMOVED                           *
      * 11/18/2013 - DEVCR-CLAIM-FLAG ADDED                         *
      * 11/18/2015 - REMOVED APC34-FLAG (MENTAL HEALTH), PTD-FLAG,  *
      *              PTD-LINE-FLAG, PTD-PROC-FLAG, AND              *
      *              C1820-OFFSET-FLAG BECAUSE THEY'RE NOT USED     *
      * 02/09/2016 - ADD LOGIC TO DETERMINE CLAIM'S DEVICE CREDIT   *
      * 02/10/2016 - DEVCR-CLAIM-FLAG REMOVED (NO LONGER USED)      *
      * 10/26/2016 - PHP-HCPCS-FLAG, MH-HCPCS-FLAG,                 *
      *              PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG,         *
      *              PTCA-CLAIM-FLAG, PTCA-LINE-FLAG REMOVED        *
      *              (NO LONGER USED)                               *
      *                                                             *
      *-------------------------------------------------------------*
             MOVE 'N'   TO BLOOD-FLAG
                           ST0-FLAG
                           N-FLAG
                           BLD-DEDUC-HCPCS-FLAG
                           C-APC-CLAIM-FLAG
                           PKG-BLD-DED-LINE-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO  TO A-OUTLIER-PYMT
                           A-TOTAL-CLM-DEDUCT
                           A-TOT-CLM-CHRG
                           A-TOT-CLM-PYMT
                           A-BLOOD-DEDUCT-DUE
                           A-BLOOD-PINTS-USED
                           A-WINX
                           W-LNC-MAX
                           A-DEVICE-CREDIT-QD.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
      *-------------------------------------------------------------*
      * INITIATILIZE WORKING STORAGE DATES - 10-23-2014             *
      *-------------------------------------------------------------*
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-BEGIN-YYYY.
             MOVE L-SERVICE-FROM-DATE(1:4) TO W-CY-END-YYYY.

      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 20100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 20100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 20100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION20 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE THE TOTAL DEVICE CREDIT AMOUNT TO BE DEDUCTED     *
      * FROM THE CLAIM - USE THE LESSER OF THE AMOUNT IN            *
      * VALUE CODE FD AND THE CAP AMOUNT IN VALUE CODE QU           *
      *-------------------------------------------------------------*
             IF L-PAYER-ONLY-VC-QU > 0 AND
                L-DEVICE-CREDIT > 0
                IF L-PAYER-ONLY-VC-QU < L-DEVICE-CREDIT
                   MOVE L-PAYER-ONLY-VC-QU TO H-CLAIM-DEVCR-AMT
                ELSE
                   MOVE L-DEVICE-CREDIT TO H-CLAIM-DEVCR-AMT
                END-IF
             END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = 'D'
                      MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
                   ELSE
      *-------------------------------------------------------------*
      *   USE SPECIAL WAGE INDEX WHEN INDICATED                     *
      *   (PSF RECORD EFFECTIVE DATE MUST BE WITHIN THE CLAIM'S CY) *
      *   ADDED 10-23-2014 FOR CY 2015                              *
      *-------------------------------------------------------------*
                      IF (L-PSF-SPEC-PYMT-IND = '1' OR '2') AND
                         (L-PSF-EFFDT >= W-CY-BEGIN-DATE AND
                          L-PSF-EFFDT <= W-CY-END-DATE)
                          MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                          MOVE L-PSF-SPEC-WGIDX TO H-WINX
                          MOVE 1484 TO H-IP-LIMIT
                          GO TO 20100-INIT-EXIT
                      ELSE
                         MOVE  52  TO A-CLM-RTN-CODE
                         GO TO 20100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 20100-INIT-EXIT.

             MOVE 1484 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      * APPLY WAGE INDEX FLOOR POLICY                               *
      * (USE HIGHER OF CBSA WAGE INDEX AND STATE RURAL WAGE INDEX)  *
      *-------------------------------------------------------------*
      * 10-23-2014 - NEW FLOOR LOGIC FOR CY 2015                    *
      * 10-28-2015 - NEW STATE CODES ADDED FOR APRIL 2016           *
      *-------------------------------------------------------------*
      *-------------------------------------------------------------*
      * >FIRST, CONFIRM FLOOR SWITCH IS SET                         *
      *-------------------------------------------------------------*
             SET W-FLOOR-LOOKUP TO TRUE.
      *-------------------------------------------------------------*
      * >GET PROVIDER'S STATE CODE FOR RURAL FLOOR WAGE INDEX       *
      *  LOOK-UP (NEW FOR JULY 2016)                                *
      *-------------------------------------------------------------*
             MOVE L-PSF-STATE-CODE TO W-PSF-PROV-ST.

      *-------------------------------------------------------------*
      * >NOW, CALL WAGE INDEX LOOKUP AND LOOK FOR THE STATE FLOOR.  *
      *  STORE PSF-CBSA IN A-CBSA (IT GETS MOVED THERE IN THE NEXT  *
      *  STEP ANYWAY). THIS FREES H-PSF-CSBA FOR THE FLOOR SEARCH   *
      *  MOVE THREE SPACES + STATE CODE TO H-PSF-CBSA               *
      *  STORE RESULT IN H-WINX.                                    *
      *  MOVE A-CBSA BACK TO H-PSF-CBSA FOR CLEANUP                 *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             STRING '   ' DELIMITED BY SIZE
                   W-PSF-PROV-ST DELIMITED BY SIZE
                   INTO H-PSF-CBSA.
             PERFORM 20200-CALC-WAGEINDX
                THRU 20200-CALC-WAGEINDX-EXIT.
             MOVE A-CBSA TO H-PSF-CBSA.

      *-------------------------------------------------------------*
      * >GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN   *
      *  BY THE PSF SPECIAL WAGE INDEX VALUE)                       *
      *                                                             *
      *   NOTE: IF PSF SPECIAL WAGE INDEX VALUE USED,               *
      *         15100-INIT-EXIT WILL BE CALLED ABOVE - THIS CODE    *
      *         WILL NEVER BE REACHED. THEREFORE CHECKING FOR A 0   *
      *         VALUE SHOULD BE UNNECESSARY.                        *
      * >SET WAGE INDEX LOOKUP FLAG (FLOOR FLAG = 'N')              *
      *-------------------------------------------------------------*
             SET W-WINX-LOOKUP TO TRUE.
                PERFORM 20200-CALC-WAGEINDX
                   THRU 20200-CALC-WAGEINDX-EXIT.

      ***************************************************************
      * DETERMINE OUTMIGRATION ADJUSTMENT BASED ON COUNTY CODE, IF  *
      * WAGE INDEX CBSA FIELD AND STANDARDIZED AMOUNT CBSA FIELD    *
      * BLANK, AND SPECIAL PYMT INDICATOR ARE BLANK APPLY ADJUSTMENT*
      * IF NOT- DONT APPLY                                          *
      ***************************************************************
             IF ( L-PSF-WI-CBSA = '     ' OR
                  L-PSF-WI-CBSA = '00000') AND
                ( L-PSF-PYMT-CBSA = '     ' OR
                  L-PSF-PYMT-CBSA = '00000') AND
                  L-PSF-SPEC-PYMT-IND = ' '

      ***************************************************************
      * INITIALIZE OUTM-IND (INDICATOR) - CLEAR VARIABLE            *
      * SEARCH FOR OUTMIGRATION COUNTY CODE MATCH WITHIN TABLE,     *
      * AT FIRST OCCURENCE USE (OUTM-IDX2) AS POINTER (REFERENCE)   *
      * FOR (OUTM-IDX) INITIAL LINE LOCATION MATCH                  *
      ***************************************************************

                INITIALIZE OUTM-IND
                SET OUTM-IDX TO 1
                SEARCH OUTM-TAB VARYING OUTM-IDX
                   AT END
                      MOVE 0 TO OUTM-IND

                   WHEN OUTM-CNTY(OUTM-IDX) =
                    L-PSF-COUNTY-CODE
                    SET OUTM-IDX2 TO OUTM-IDX
                    MOVE 1 TO OUTM-IND
             END-IF.

      ***************************************************************
      * WHEN OUTM-IND = 1, THIS MEANS COUNTY CODE MATCH WAS FOUND   *
      * LOOP THRU EACH LINE THEN PERFORM PARAGRAPH UNTIL CONDITION  *
      * (IF-STATEMENT) IS TRUE, THE COUNTY CODES NO LONGER MATCH    *
      * ON LAST LINE OF DATE MATCH FOR COUNTY CODE, MOVE            *
      * OUTMIGRATION ADJUSTMENT, TO HLD-OUTM-ADJ VARIABLE           *
      * FOR COMPUTATION                                             *
      ***************************************************************
               IF OUTM-IND = 1
                 PERFORM 20120-GET-OUTM-ADJ THRU
                           20120-GET-OUTM-ADJ-EXIT
                  VARYING OUTM-IDX2 FROM OUTM-IDX BY 1 UNTIL
                OUTM-CNTY(OUTM-IDX2) NOT = L-PSF-COUNTY-CODE
      ***************************************************************
      * FOR FYS 2018 AND AFTER, APPLY THE OUTMIGRATION ADJUSTMENT   *
      * ADD OUT MIGRATION ADJUST TO WAGE INDEX FOR NEW H-WINX       *
      ***************************************************************
                COMPUTE H-WINX = H-WINX + HLD-OUTM-ADJ
               END-IF.
      ***************************************************************
      * 12/07/2020 - UPDATED QUARTILE FROM 0.8457 TO 0.8469         *
      * PROVIDERS BELOW WAGE INDEX OF 0.8469 WILL RECIEVE A BOOST   *
      * IN THEIR WAGE INDEX.                                        *
      ***************************************************************
                 PERFORM 20121-WI-QUARTILE-ADJ THRU
                         20121-WI-QUARTILE-ADJ-EXIT.
      ***************************************************************
      * ALL PROVIDERS ELIGIBLE FOR TRANSITION DUE TO CHANGE         *
      * OF RURAL FLOOR POLICY: USING RURAL WAGE INDEX               *
      ***************************************************************
                 PERFORM 20122-WI-TRANSITION-ADJ THRU
                         20122-WI-TRANSITION-ADJ-EXIT.

       20100-INIT-EXIT.
           EXIT.

       20120-GET-OUTM-ADJ.
             IF OUTM-EFF-DATE(OUTM-IDX2) <= L-SERVICE-FROM-DATE AND
                OUTM-EFF-DATE(OUTM-IDX2) >= W-CY-BEGIN-DATE AND
                OUTM-EFF-DATE(OUTM-IDX2) <= W-CY-END-DATE
                 MOVE OUTM-ADJ-FACT(OUTM-IDX2) TO HLD-OUTM-ADJ
             END-IF.
       20120-GET-OUTM-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *              QUARTILE ADJUSTMENT OF WAGE INDEX              *
      ***************************************************************
      * PROVIDERS BELOW WAGE INDEX OF 0.8469 WILL RECIEVE A BOOST   *
      * IN THEIR WAGE INDEX.                                        *
      *   THIS WILL BE EFF. FOR 4 YEARS (CY2020 - CY2023)           *
      *       - THE STATIC 0.8469 WILL CHANGE EVERY YEAR            *
      *       - PLEASE UPDATE WI-QUARTILE-CY20**  ANNUALLY          *
      *                                                             *
      ***************************************************************
       20121-WI-QUARTILE-ADJ.
                IF H-WINX < WI-QUARTILE-CY2021
                   COMPUTE H-WINX ROUNDED =
                    ((WI-QUARTILE-CY2021 - H-WINX) / 2)
                     + H-WINX
                END-IF.
       20121-WI-QUARTILE-ADJ-EXIT.
           EXIT.

      ***************************************************************
      * ALL PROVIDERS ELIGIBLE FOR TRANSITION DUE TO CHANGE         *
      * OF RURAL FLOOR POLICY: USING RURAL WAGE INDEX               *
      *       - COMPARE CURRENT CY TO SUPPLEMENTAL WAGE INDEX       *
      *         IF WAGE INDEX GOES DOWN BY MORE THAN 5% BETWEEN     *
      *         CURRENT CY AND SUPPLEMENTAL WI ASSIGN SUPPLEMENTAL  *
      *         WAGE INDEX WITH A CAP OF THE 5% REDUCTION           *
      *       - IF PROVIDER SPECIAL WAGE INDEX OR SUPPLEMENTAL WAGE *
      *         INDEX NOT POPULATED, PRICER WILL SKIP CAPPING LOGIC *
      *         AND USE THE 2021 CBSA WAGE INDEX TO PRICE CLAIM     *
      *       - ADDED VALIDATION FOR SUPPLEMENTAL WAGE INDEX AND    *
      *         INDICATOR WITH RETURN CODE 50                       *
      ***************************************************************
       20122-WI-TRANSITION-ADJ.

      ***************************************************************
      *    SUPPLEMENTAL WAGE INDEX VALIDATION > 0                   *
      ***************************************************************
            IF L-PSF-SUPPL-WI-IND = '1' AND
               (L-PSF-SUPPL-WI NOT > 0 OR
                L-PSF-SUPPL-WI NOT NUMERIC)
                  MOVE 50 TO A-CLM-RTN-CODE
                  GO TO 20122-WI-TRANSITION-ADJ-EXIT
            END-IF.

      ***************************************************************
      *    SUPPLEMENTAL WAGE INDEX DATE VALIDATION                  *
      ***************************************************************

            IF L-PSF-SUPPL-WI-IND = '1' AND
               (L-PSF-EFFDT < W-CY-BEGIN-DATE OR
                  L-PSF-EFFDT > W-CY-END-DATE)
                  MOVE 50 TO A-CLM-RTN-CODE
                  GO TO 20122-WI-TRANSITION-ADJ-EXIT
            END-IF.

            IF L-PSF-SUPPL-WI-IND = '1' AND
               L-PSF-SUPPL-WI > 0

              IF (((H-WINX - L-PSF-SUPPL-WI) / L-PSF-SUPPL-WI)
                 < WI-PCT-REDUCT-CY2020)
                   COMPUTE H-WINX ROUNDED =
                      L-PSF-SUPPL-WI * WI-PCT-ADJ-CY2020
              END-IF
            END-IF.

       20122-WI-TRANSITION-ADJ-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND APC / HCPCS/ FLAGS  *
      *                                                             *
      *  - SET FLAG IF APC = 5851/5852/5861/5862 (PARTIAL HOSP.)    *
      *  - SET FLAG IF PASS-THROUGH RADIOPHARMS(S) ON CLAIM         *
      *    (NEW FOR APRIL CY 2009 - ADDED 02/10/2009)               *
      *  - SET FLAG IF PASS-THROUGH CONTRAST AGENT(S) ON CLAIM      *
      *    (NEW FOR JANUARY CY 2010 - ADDED 11/15/2009)             *
      *  - SET FLAG IF CLAIM IS ELIGIBLE FOR DEVICE CREDIT          *
      *    (NEW FOR JANUARY CY 2014)                                *
      *  - SET FLAG IF CLAIM HAS A COMPREHENSIVE APC (C-APC) LINE   *
      *    (NEW FOR JULY 2016)                                      *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION HCPCS FROM     *
      *              0033 TO 0172 & 0173 FOR CY 2009                *
      *                                                             *
      * 11/12/2008 - HCPCS C1820 EXPIRED FROM PASS-THROUGH STATUS   *
      *              DECEMBER 2007, OFFSET FLAG LOGIC DISABLED      *
      *                                                             *
      * 08/02/2010 - ADDED LOGIC TO SET PASS-THOUGH DEVICE FLAG FOR *
      *              DEVICE OFFSETS AND POPULATE THE CORRESPONDING  *
      *              TABLE                                          *
      *                                                             *
      * 11/15/2010 - ADDED APCS 0175 & 0176 TO LIST OF PHP APCS     *
      *                                                             *
      * 11/18/2013 - ADDED LOGIC TO SET DEVICE CREDIT CLAIM FLAG    *
      *                                                             *
      * 11/17/2015 - REMOVED LOGIC TO SET FLAGS FOR PASS-THROUGH    *
      *              DEVICES (FOR OUTLIER & OFFSET LOGIC)           *
      *            - UPDATED PHP APCS FOR 2016                      *
      *            - REMOVED APC34-FLAG (MENTAL HEALTH) - NOT USED  *
      *            - REMOVED APC 0339 UNITS OVERRIDE                *
      *                                                             *
      * 05/09/2016 - ADDED LOGIC TO SET COMPREHENSIVE APC CLAIM FLAG*
      * 10/26/2016 - REMOVED PHP APC CHECK, PT RADIOPHARM CHECK,    *
      *              AND PT CONTRAST AGENT CHECK                    *
      *                                                             *
      ***************************************************************
       20125-INIT.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A COMPREHENSIVE APC     *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = 'J1' OR
                OPPS-SRVC-IND (LN-SUB) = 'J2'
                MOVE 'Y' TO C-APC-CLAIM-FLAG
             END-IF.


       20125-INIT-EXIT.
           EXIT.




      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0, 6, 7, 8,    *
      *                9, OR 'A' (PAYMENT METHOD FLAG)              *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       20150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 20250-CALC-DISCOUNT
                THRU 20250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 20150-INIT-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 10/26/2016 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG REMOVED         *
      *-------------------------------------------------------------*
             MOVE 'N' TO PKG-BLD-DED-LINE-FLAG.


      ***************************************************************
      *   IDENTIFY LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE ON       *
      *   A CLAIM WITH A COMPREHENSIVE APC; TREAT AS PACKAGED LINE  *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      ***************************************************************
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             END-IF.


      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR ' L' OR
                ' N' OR ' P' OR ' R' OR ' S' OR ' T' OR ' U' OR
                ' V' OR ' X' OR ' W' OR ' Y' OR ' Z' OR ' M' OR
                'J1' OR 'J2')
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 20150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' K' OR ' L' OR ' W' OR
                ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 20150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      * 10/26/2016- REMOVED PHP/MENTAL HEALTH CODE LISTS            *
      * 01/19/2017- ADDED '3' INTO LOGIC, FOR FISS INFORMATINAL USE *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF  OPPS-LITEM-DR-FLAG (LN-SUB) = ('0' OR '3') OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                       OPPS-LITEM-ACT-FLAG (LN-SUB) = '1'



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      * 11/03/2008 - REMOVED PAFS 91 - 99 FOR COMPOSITES FOR CY 2009*
      * 04/11/2011 - ADDED ' 9' & '10' AS VALID PAFS FOR CY 2011    *
      * 12/18/2014 - ADDED '11' FOR CY 2015                         *
      * 11/10/2015 - ADDED '12' - '14' FOR CY 2016                  *
      * 02/05/2016 - ADDED '16' - '20' FOR CY 2016                  *
      *              (PAF '15' RESERVED FOR FUTURE USE)             *
      * 08/11/2016 - ADDED '21' FOR CY 2016                         *
      * 10/16/2017 - ADDED '22' FOR CY 2018                         *
      * 10/23/2018 - ADDED '23' FOR CY 2019                         *
      * 10/23/2018 - ADDED '24' FOR CY 2019                         *
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8' OR ' 9' OR '10' OR '11'
                             OR '12' OR '13' OR '14'         OR '16'
                             OR '17' OR '18' OR '19' OR '20' OR '21'
                             OR '22' OR '23' OR '24'


      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *                                                             *
      *   ** SITE OF SERVICE FLAG = PAYMENT METHOD FLAG IN OCE **   *
      *                                                             *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', PHP APC IS ON THE CURRENT LINE       *
      *-------------------------------------------------------------*
      * 11/06/2007 - CHANGED PHP HEALTH CODES LISTED FROM           *
      *              APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008   *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION APC FROM       *
      *              0033 TO 0172 & 0173 FOR CY 2009, FLAG CHANGED  *
      *              FROM APC33-FLAG TO PHP-APC-FLAG                *
      * 10/19/2016 - ADDED VALUES '7' AND '8' FOR SECTION 603       *
      *              SERVICE LINES (MODIFIER 'PN')                  *
      * 10/26/2016 - REMOVED PHP SPECIFIC LOGIC                     *
      * 03/02/2017 - ADD PMF FLAG '9' VALUE TO VALID LIST           *
      * 11/05/2018 - ADD PMF FLAG 'A' VALUE TO VALID LIST           *
      * 11/12/2019 - ADD PMF FLAG 'Y' VALUE TO VALID LIST           *
      * 12/02/2019 - ADD PMF FLAG 'X' VALUE TO VALID LIST           *
      * 12/02/2019 - ADD PMF FLAG 'Z' VALUE TO VALID LIST           *
      * 09/22/2020 - ADD PMF FLAG 'B' VALUE TO VALID LIST           *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = '9') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'A') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Z') OR
                            (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'B')



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE ALL PACKAGED COMPOSITE LINES                      *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *   11/12/2008 - CHANGED LOGIC THAT EXCLUDES ALL COMPOSITE    *
      *                LINES & MENTAL HEALTH PKG LINES TO USE THE   *
      *                COMPOSITE ADJUSTMENT FLAG INSTEAD OF PAYMENT *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *   05/09/2016 - ADDED LOGIC TO ENSURE BLOOD DEDUCTIBLE LINES *
      *                ON CLAIMS WITH A COMPREHENSIVE APC ARE       *
      *                INCLUDED                                     *
      *-------------------------------------------------------------*
                IF ( (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                     (OPPS-COMP-ADJ-FLAG (LN-SUB) = '00') ) OR
                     PKG-BLD-DED-LINE
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED REVENUE CODE 39X BLOOD LINE CHARGES   *
      *   (BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC)      *
      *   WHEN BILLED ON CLAIM WITH A COMPREHENSIVE APC TO          *
      *   DETERMINE THE PORTION OF THE BLOOD APC PAYMENT TO BE      *
      *   DISTRIBUTED TO THE BLOOD PRODUCT (PAF = 5) LINE FOR THE   *
      *   BLOOD DEDUCTIBLE CALCULATION                              *
      *-------------------------------------------------------------*
      *   05/16/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' N' AND
               (OPPS-LITEM-RVCD (LN-SUB) = '0390' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0392' OR
                OPPS-LITEM-RVCD (LN-SUB) = '0399')
                  COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB) +
                                          H-TOT-38X-39X
             END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME (PACKAGED) COMPOSITE APC CHARGES     *
      *   FOR EACH COMPOSITE APC BY THE COMPOSITE ADJUSTMENT FLAG   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2007 - LOGIC REVISED FOR CY 2009 TO IDENTIFY ALL    *
      *                COMPOSITE LINES USING THE COMPOSITE          *
      *                ADJUSTMENT FLAG INSTEAD OF PAYMENT           *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *                (INCLUDES PROCESSING FOR MENTAL HEALTH       *
      *                 COMPOSITES)                                 *
      *-------------------------------------------------------------*
                IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "00" AND
                   OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "  " AND
                   OPPS-SRVC-IND (LN-SUB) = ' N'
                      PERFORM 20170-COMPOSITES
                         THRU 20170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   SET RETURN CODE & EXIT WHEN PACKAGED LINE/LINE APC = 0000 *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 20150-INIT-EXIT
                END-IF


      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 20150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 20175-APC-LOOKUP

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT METHOD FLAG = '8' (603 SV)*
      *   SET THE COINSURANCE AND REIMBURSEMENT TO PFS RATES        *
      *   10/16/2017 - NEW FOR CY 2018; PAYS 40% OFF THE OPPS RATE  *
      *   11/08/2019 - PAYS 40% OFF THE OPPS RATE                   *
      *   11/12/2019 - ADD PMF = 'Y' TO PMF = '8' LOGIC (603 SV)    *
      *   12/02/2019 - ADD PMF = 'X' TO PMF = '7' LOGIC (603 SV)    *
      *   09/22/2020 - ADD PMF = 'B' TO APPLY MIN 20% COINSURANCE   *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '8' OR 'Y'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * PFS-REDUCT-2018
                      END-IF

                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = '8' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y' OR
                         OPPS-SITE-SRVC-FLAG (LN-SUB) = 'B'
                         COMPUTE H-MIN-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         COMPUTE H-NAT-COIN ROUNDED =
                                 H-APC-PYMT * COIN-RATE-20
                         MOVE    PFS-REIM-RATE TO H-PPCT
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT METHOD FLAG = 'A'         *
      *   PAY 70% OF APC RATE                                       *
      *   11/05/2018 - NEW FOR CY 2019; 30% REDUCTION OF APC RATE   *
      *   10/22/2019 - AMERICAN HOSPITAL ASSOCIATION ET AL V. AZAR  *
      *    LAWSUIT    REMOVE PMF = 'A' LOGIC EFF. 10/22/2019        *
      *-------------------------------------------------------------*
      *   11/12/2019 - NEW FOR CY 2020; PAYS 40% OF APC RATE        *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) = 'A'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * PMF-A-REDUCT-2020
                      END-IF


      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '14' (CT SCAN) *
      *   11/10/2015 - NEW FOR CY 2016; 5% REDUCTION                *
      *   07/15/2016 - NEW FOR CY 2017; 15% REDUCTION               *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '14'
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * CT-REDUCT-2017
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '21' OR '23'   *
      *   (X-RAY SV)                                                *
      *   08/11/2016 - NEW FOR CY 2017; 20% REDUCTION FOR FILM XRAY *
      *   10/23/2018 - ADD PAF 23 FOR CY 2019                       *
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ('21' OR '23')
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * XRAY-FILM-REDUCT-2017
                      END-IF


      *-------------------------------------------------------------*
      *   REDUCE APC PMT OF LINE WITH PMT ADJ FLAG = '22' OR '24'   *
      *   (X-RAY SV)                                                *
      *   07/18/2017 - NEW FOR CY 2018; 07% REDUCTION FOR CRT XRAY  *
      *   10/23/2018 - ADD PAF 24 FOR CY 2019                       *
      *** REDUCTION RATE WILL CHANGE TO 10% FOR CY 2023         *****
      *-------------------------------------------------------------*
                      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ('22' OR '24')
                         COMPUTE H-APC-PYMT ROUNDED =
                                 H-APC-PYMT * XRAY-CRT-REDUCT-2018
                      END-IF

      *-------------------------------------------------------------*
      *   REDUCE APC PMT BY REDUCED UPDATE RATIO WHEN APPROPRIATE   *
      *   11/13/2009 - NEW FOR CY 2009 (QUALITY)                    *
      *   10/19/2016 - EXCLUDE 603 SERVICES FROM QUALITY REDUCTION  *
      *                (PMT METHOD FLAG = 7 OR 8)                   *
      *   12/02/2019 - (PMT METHOD FLAG = X AND Y)EXCLUDED QUALITY  *
      *   09/22/2020 - EXCLUDE RO MODEL FROM QUALITY REDUCTION      *
      *                (PMT METHOD FLAG = B) EXCLUDED QUALITY       *
      *-------------------------------------------------------------*
                      IF OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = 'X' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = 'Y' AND
                         OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = 'B'
                         PERFORM 20180-REDUCE-APC-PYMT
                            THRU 20180-REDUCE-APC-PYMT-EXIT
                      END-IF



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 20150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 20150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 20150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 20150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 20150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 20150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF LINES ELIGIBLE FOR DEVICE CREDIT *
      * WHEN THE CLAIM'S TOTAL DEVICE CREDIT IS > $0 AND THE LINE   *
      * HAS PAYMENT ADJUSTMENT FLAG '17'                            *
      * - REVISED DEVICE CREDIT LOGIC FOR APRIL 2016                *
      ***************************************************************
             IF H-CLAIM-DEVCR-AMT > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17'
                COMPUTE H-TOT-DEVCR-PYMTS =
                        H-TOT-DEVCR-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE APC PAYMENTS OF TERMINATED PROCEDURE LINES       *
      * ELIGIBLE FOR DEVICE OFFSET WHEN PAYER ONLY VALUE CODE QQ    *
      * IS > $0 AND THE LINE HAS PAYMENT ADJUSTMENT FLAG '16'       *
      * (LINE MODIFIER IS 73)                                       *
      * - IMPLEMENTED IN APRIL 2016                                 *
      ***************************************************************
             IF L-PAYER-ONLY-VC-QQ > 0 AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16'
                COMPUTE H-TOT-TPDO-PYMTS =
                        H-TOT-TPDO-PYMTS +
                        H-APC-PYMT
             END-IF.


      ***************************************************************
      * ACCUMULATE LINE CHARGES OF PASS-THROUGH DEVICE LINES        *
      * ASSOCIATED WITH PAYER ONLY VALUE CODES QN AND QO            *
      * - LINES WITH PAF '12' RECEIVE OFFSET IN VALUE CODE QN       *
      * - LINES WITH PAF '13' RECEIVE OFFSET IN VALUE CODE QO       *
      * - LINES WITH PAF '15' RECEIVE OFFSET IN VALUE CODE QP       *
      * NEW FOR CY2016 - 11/13/2015                                 *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
                COMPUTE H-QN-TOT-PTD-CHARGES =
                        H-QN-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
                COMPUTE H-QO-TOT-PTD-CHARGES =
                        H-QO-TOT-PTD-CHARGES +
                        OPPS-SUB-CHRG (LN-SUB)
             END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *      IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *         COMPUTE H-QP-TOT-PTD-CHARGES =
      *                 H-QP-TOT-PTD-CHARGES +
      *                 OPPS-SUB-CHRG (LN-SUB)
      *      END-IF.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                PERFORM 20300-COIN-DEDUCT
                   THRU 20300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2009.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                SET W21BD-INDX TO 1
                SEARCH W21BD-ENTRY VARYING W21BD-INDX
                   AT END
                      GO TO 20150-INIT-EXIT
                   WHEN W-2021-BLOOD-HCPCS (W21BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-2021-BLOOD-RANK (W21BD-INDX) TO H-BLOOD-RANK
                     MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                     PERFORM 20375-BLOOD-DEDUCT
                        THRU 20375-BLOOD-DEDUCT-EXIT
                    END-IF.

       20150-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH COMPOSITE          *
      *  ADJUSTMENT FLAG NOT = '00' & POPULATE COMPOSITE APC TABLE  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY COMPOSITE ADJUSTMENT FLAG (CAF) -   *
      *    LOWEST TO HIGHEST FLAG VALUE (01 - NN)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH CAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *  11/12/2008 - LOGIC REVISED FOR CY 2009 TO USE THE          *
      *               COMPOSITE ADJUSTMENT FLAG INSTEAD OF THE      *
      *               PAYMENT ADJUSTMENT FLAG, VARIABLE H-CMP-CAF   *
      *               HOLDS COMPOSITE ADJUSTMENT FLAG, VARIABLE     *
      *               W-CMP-PAF RETAINED AND NOW HOLDS THE CAF      *
      *               (RETAINED TO CONTINUE USE OF EXISTING TABLE)  *
      *                                                             *
      ***************************************************************
       20170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S COMPOSITE ADJUSTMENT FLAG FOR TABLE SEARCH   *
      *-------------------------------------------------------------*
             MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE CAF         *
      *-------------------------------------------------------------*
                PERFORM 20171-SEARCH-CAF
                   THRU 20171-SEARCH-CAF-EXIT.

       20170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       20171-SEARCH-CAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS NOT      *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 20172-ADD-ENTRY
                      THRU 20172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS ALREADY  *
      * IN THE TABLE, UPDATE THE ENTRY                              *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                   PERFORM 20173-UPDATE-ENTRY
                      THRU 20173-UPDATE-ENTRY-EXIT.

       20171-SEARCH-CAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       20172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS COMPOSITE ADJUSTMENT FLAG (CAF) - LOWEST TO HIGHEST CAF *
      *-------------------------------------------------------------*
             PERFORM 20174-STAGE-CMP-ENTRY
                THRU 20174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-CAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-CAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       20172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * COMPOSITE ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE       *
      *                                                             *
      ***************************************************************
       20173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE CAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       20173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER CAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       20174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       20174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       20175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 20175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       20175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      REDUCE APC PAYMENT OF LINES FROM PROVIDERS WITH A      *
      *      SPACE IN THE QUALITY INDICATOR FIELD OF THE OPSF       *
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      *  11/16/2010 - ADDED SI = U (BRACHY) TO LOGIC                *
      *                                                             *
      ***************************************************************
       20180-REDUCE-APC-PYMT.

      *-------------------------------------------------------------*
      *  SPECIFY LINES ELIGIBLE FOR REDUCTION                       *
      *  11/13/2019- QUALITY ADJUSTMENT EXCLUSION FOR NEW TECHNOLOGY*
      *  CATEGORY APC RANGES:                                       *
      *             - 1575-1599 (EFF. 1/1/2016)                     *
      *             - 1901-1906 (EFF. 1/1/2017)                     *
      *             - 1907-1908 (EFF. 1/1/2018)                     *
      *  09/22/2020- QUALITY ADJUSTMENT EXCLUSION FOR RO MODEL      *
      *  CATEGORY APC RANGES:                                       *
      *             - 6073-6105 (EFF. 7/1/2020)                     *
      *  12/08/2020- QUALITY ADJUSTMENT FACTOR = '0.9805'           *
      *-------------------------------------------------------------*
             IF ( L-PSF-HOSP-QUAL-IND = ' ' )  AND

                (  (OPPS-SRVC-IND (LN-SUB) = ' P')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' R')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' S' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01491' AND
                           OPPS-GRP (LN-SUB) <= '01537') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01575' AND
                           OPPS-GRP (LN-SUB) <= '01585') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01908') AND
                      NOT (OPPS-GRP (LN-SUB) >= '06073' AND
                           OPPS-GRP (LN-SUB) <= '06105'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' T' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01539' AND
                           OPPS-GRP (LN-SUB) <= '01574') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01589' AND
                           OPPS-GRP (LN-SUB) <= '01599') AND
                      NOT (OPPS-GRP (LN-SUB) >= '01901' AND
                           OPPS-GRP (LN-SUB) <= '01908'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' U')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' V')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' X')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J1')  OR

                   (OPPS-SRVC-IND (LN-SUB) = 'J2')  ) THEN
                COMPUTE H-APC-PYMT ROUNDED = H-APC-PYMT * 0.9805
                MOVE 11 TO A-RETURN-CODE (LN-SUB)

             END-IF.


       20180-REDUCE-APC-PYMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       20200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   IF W-WINX-LOOKUP
                      MOVE  50  TO A-CLM-RTN-CODE
                   END-IF
                   GO TO 20200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA
      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 20210-WAGE-LOOKUP.

      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0 OR NOT NUMERIC             *
      *   *AND* NOT ON RURAL FLOOR LOOKUP                           *
      ***************************************************************

             IF (H-WINX = 0 OR H-WINX NOT NUMERIC) AND
                 W-WINX-LOOKUP THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       20200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       20210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE MEETS THE CRITERIA:       *
      *  - MUST NOT BE AFTER THE LATEST WAGE INDEX EFFECTIVE DATE   *
      *    THAT CAN BE USED BY THE CLAIM                            *
      *  - EXCEPT FOR INDIAN HEALTH PROVIDERS (CBSAS 98 AND 99),    *
      *    MUST BE WITHIN THE CLAIM'S CALENDAR YEAR                 *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD / LATEST         *
      *   EFFECTIVE DATE FOR THE CBSA)                              *
      ***************************************************************
             MOVE WCW-DTCD (W-SUB3) TO W-WCW-DTCD.

             IF W-WCW-DTCD NOT > WCD-DTCD (WCD-SUB) AND

                ( (WCD-DATE (W-WCW-DTCD) >= W-CY-BEGIN-DATE AND
                   WCD-DATE (W-WCW-DTCD) <= W-CY-END-DATE AND
                   H-PSF-CBSA NOT = '   98' AND
                   H-PSF-CBSA NOT = '   99') OR

                  (H-PSF-CBSA = '   98' OR
                   H-PSF-CBSA = '   99') )


      *-------------------------------------------------------------*
      *   THIS LOOKS UP PROVIDERS RURAL FLOOR IN THIRD COLUMN OF    *
      *   WAGE INDEX TABLE                                          *
      *   IF FOUND, STORE RURAL WAGE INDEX  RESULT IN H-WINX        *
      *   (RURAL FLOOR LOOKUP IS PERFORMED BEFORE CBSA WAGE INDEX   *
      *    LOOKUP)                                                  *
      *-------------------------------------------------------------*
                IF W-FLOOR-LOOKUP
                      MOVE WCW-WINX3 (W-SUB3) TO H-WINX
                END-IF
      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *   *ONLY VALID FOR WAGE INDEX LOOKUP, NOT RURAL FLOOR*       *
      *   IF WAGE INDEX > FLOOR, OVERWRITE H-WINX                   *
      *-------------------------------------------------------------*
                IF W-WINX-LOOKUP
                   IF L-PSF-SPEC-PYMT-IND = 'Y' THEN
                      IF WCW-WINX2 (W-SUB3) > H-WINX THEN
                         MOVE WCW-WINX2 (W-SUB3) TO H-WINX
                      END-IF
      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *   IF WAGE INDEX > FLOOR  -STORE  RESULT IN H-WINX.          *
      *-------------------------------------------------------------*
                   ELSE
                      IF WCW-WINX1 (W-SUB3) > H-WINX
                         MOVE WCW-WINX1 (W-SUB3) TO H-WINX
                      END-IF
                   END-IF
                END-IF

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE DID NOT MEET THE CRITERIA *
      *  - AFTER THE LATEST EFFECTIVE DATE THE CLAIM CAN USE -OR-   *
      *  - NOT WITHIN THE CLAIM'S CALENDAR YEAR AND NOT IN CBSA     *
      *    98 OR 99                                                 *
      *  GO TO THE PRIOR RECORD FOR THIS CBSA WITH AN EARLIER DATE  *
      *  IN THE CBSA WAGE INDEX TABLE.                              *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *  AGAIN AND REPEAT THE PROCESS
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 20210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      * >10-28-2014 ONLY VALID FOR WAGE INDEX PASS, NOT RURAL FLOOR *
      *-------------------------------------------------------------*
                ELSE

                   IF W-WINX-LOOKUP
                      MOVE 0 TO H-WINX
                END-IF
             END-IF.

       20210-WAGE-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       20250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 20250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       20250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       20300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 20350-STAGE-ENTRY
                THRU 20350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX      TO W-WINX (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       20300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       20350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       20350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       20375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 20385-STAGE-ENTRY
                THRU 20385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX     TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       20375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       20385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       20385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PAYMENTS, DEDUCTIBLES, REIM., & COINSURANCE,*
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       20400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 20400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 20550-CALC-STANDARD
                   THRU 20550-CALC-STANDARD-EXIT
             ELSE
                GO TO 20400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRUG COINSURANCE TABLE FOR LATER PROCESSING        *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET BLOOD-FLAG WHEN SERVICE INDICATOR = R (BLOOD)        *
      *  - EXCLUDE PACKAGED BLOOD DEDUCTIBLE LINES & SECTION 603    *
      *    SERVICE LINES                                            *
      *  - ADDED PMF ='X' AND 'Y' TO BE EXCLUDED SECTION 603 SV LINE*
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30 AND
                NOT PKG-BLD-DED-LINE AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X' AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = '8' AND
                NOT OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y'

                PERFORM 20450-ADJ-PROC-COIN
                   THRU 20450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 20500-ADJ-CHRGS
                THRU 20500-ADJ-CHRGS-EXIT.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

                COMPUTE A-DEVICE-CREDIT-QD =
                        A-DEVICE-CREDIT-QD + H-LINE-DEVCR-AMT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 15840-PROCESS-TYPE2     *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)


               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       20400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      POPULATE COINSURANCE CAP ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: BLOOD LINE                              *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY BLOOD LINE         *
      *                                                             *
      * COINSURANCE RECORD COMBINATIONS:                            *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       BLOOD ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT   *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO BLOOD ADMINISTERED ON THE   *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH BLOOD ADMINISTERED ON THE      *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = R =>               *
      *       BLOOD ADMINSTERED ON THE DATE OF SERVICE              *
      *                                                             *
      ***************************************************************
       20450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT
      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                PERFORM 20455-SEARCH-KEY
                   THRU 20455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = R LINES (BLOOD)                                *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET BLOOD-FLAG TO INDICATE BLOOD LINE                       *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO BLOOD-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE COINSURANCE TABLE ENTRY FOR THE DOS           *
      *-------------------------------------------------------------*
                   PERFORM 20455-SEARCH-KEY
                      THRU 20455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY BLOOD LINE)*
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = R       *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW BLOOD COINSURANCE ENTRY             *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 20475-STAGE-DCP-ENTRY
                      THRU 20475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, BLOOD                                        *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       20450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COINSURANCE CAP ROLL-UP TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       20455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH COINSURANCE CAP TABLE STARTING AT ENTRY #1           *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 20460-ADD-ENTRY
                      THRU 20460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 20465-UPDATE-ENTRY
                      THRU 20465-UPDATE-ENTRY-EXIT.

       20455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE COINSURANCE TABLE                                       *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       20460-ADD-ENTRY.
      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COINSURANCE CAP TABLE ENTRY         *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 20475-STAGE-DCP-ENTRY
                THRU 20475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, BLOOD                                        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       20460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COINSURANCE RECORD WITH THE SAME        *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       20465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR BLOOD LINES - ACCUMULATE DAY'S TOTAL BLOOD COIN DUE     *
      * -REMOVE ' G' & ' K'                                         *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A BLOOD LINE, UPDATE THE RECORD   *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 20485-REPLACE-TYPE1
                     THRU 20485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 20480-RANK-COIN
                     THRU 20480-RANK-COIN-EXIT.

       20465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COINSURANCE RECORD WITH A HIGHER          *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       20475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       20475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST ACTUAL     *
      * COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE           *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *  CHANGED TO ACTUAL FROM NATIONAL COINSURANCE FOR 2018       *
      ***************************************************************
       20480-RANK-COIN.

             IF H-NEW-COIN > W-DCP-COIN1 (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       20480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = R        *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = BLOOD LINE NEW COINSURANCE AMOUNT(S)              *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       20485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       20485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 15600-ADJ-CHRG-OUTL.)                     *
      *                                                             *
      ***************************************************************
       20500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
      * 12/18/2009 - ADD SIS R & U, WHICH ARE ELIGIBLE FOR OUTLIER  *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P' OR ' R' OR ' U' OR 'J1' OR 'J2')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                AND NOT PKG-BLD-DED-LINE
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       20500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    & TAKE PT DEVICE OFFSET WHEN APPLICABLE                  *
      * 5. CALCULATE AND APPLY DEVICE CREDIT                        *
      *                                                             *
      ***************************************************************
       20550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 20655-SET-BD-HCPCS-FLAG
                THRU 20655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      *   FLAG LINE IF ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND CLAIM  *
      *   HAS A COMPREHENSIVE APC; TREAT AS PACKAGED LINE           *
      *   BUT LINE PAYMENT WILL REFLECT THE DEDUCTIBLE DUE          *
      *-------------------------------------------------------------*
      *   05/09/2016 - NEW FOR JULY 2016                            *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  SET PKG-BLD-DED-LINE TO TRUE
             ELSE
                  MOVE 'N' TO PKG-BLD-DED-LINE-FLAG
             END-IF.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).

      ***************************************************************
      * CALCULATE DEVICE CREDIT FOR ELIGIBLE LINE(S)                *
      *-------------------------------------------------------------*
      * 02/09/2016- REVISED LOGIC IMPLEMENTED IN APRIL 2016         *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-CLAIM-DEVCR-AMT > 0 AND
                H-TOT-DEVCR-PYMTS > 0
                PERFORM 20550-DEVICE-CREDIT
                   THRU 20550-DEVICE-CREDIT-EXIT.


      ***************************************************************
      * CALCULATE DEVICE OFFSET FOR ELIGIBLE TERMINATED PROCEDURE   *
      * LINES AND REDUCE THE APC PAYMENT BY THE DEVICE OFFSET AMOUNT*
      *-------------------------------------------------------------*
      * 02/09/2016- NEW LOGIC IMPLEMENTED IN APRIL 2016             *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '16' AND
                L-PAYER-ONLY-VC-QQ > 0 AND
                H-TOT-TPDO-PYMTS > 0
                PERFORM 20550-TERM-PROC-DEV-OFF
                   THRU 20550-TERM-PROC-DEV-OFF-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, X, J1, OR J2 LINES   *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      * 10/26/2016 - STOPPED PERFORMING PHP OUTLIER CAPPING LOGIC   *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X' OR
                 'J1' OR 'J2') THEN
                  PERFORM 20550-SCH-ADJ
                     THRU 20550-SCH-ADJ-EXIT
                  PERFORM 20560-CALC-BENE-DEDUCT
                     THRU 20560-CALC-BENE-DEDUCT-EXIT


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (PT DEVICE) LINES, PAYMENT IND.*
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      *-------------------------------------------------------------*
      * 01/01/2009 - BRACHYTHERAPY SERVICES ADDED FOR CY 2009       *
      * 11/15/2009 - BRACHYTHERAPY SERVICES (SI=U) REMOVED CY 2010  *
      *            - THERAPEUTIC RADIOPHARMS' SI NOT 'H' FOR CY2010 *
      * 08/11/2010 - NEW PASS-THROUGH DEVICE OFFSET LOGIC ADDED IN  *
      *              PARAGRAPH 10555-CALC-H-STANDARD                *
      * 11/16/2015 - REVISED PT-DEVICE LOGIC: 15555-CALC-H-STANDARD *
      ***************************************************************
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' H') THEN
                 IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                       OPPS-PYMT-IND (LN-SUB) = ' 6')
                   PERFORM 20555-CALC-H-STANDARD
                      THRU 20555-CALC-H-STANDARD-EXIT
                   PERFORM 20560-CALC-BENE-DEDUCT
                      THRU 20560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 20550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = R & U LINES; THE PMT. IND.       *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      * 11/15/2009 - ADDED BRACHYTHERAPY SERVICES (SI=U) FOR CY2010 *
      *              THERAPEUTIC RADIOPHARMS' SI=K FOR CY 2010      *
      * 11/16/2009 - ADD LOGIC TO ADJUST PT CONTRAST AGENT HCPCS    *
      *              LINE PAYMENT BY OFFSET                         *
      * 05/10/2016 - CALCULATE BLOOD DEDUCTIBLE & LINE PAYMENT FOR  *
      *              BLOOD DEDUCTIBLE LINES ON COMPREHEMSIVE APC    *
      *              CLAIMS (THESE LINES WERE PREVIOUSLY PACKAGED)  *
      *            - ADD LOGIC TO EXEMPT BLOOD DEDUCTIBLE LINES ON  *
      *              COMPREHENSIVE APC CLAIMS FROM REIM, COIN, &    *
      *              NON-BLOOD DEDUCTIBLE CALCS.                    *
      * 10/21/2016 - NO LONGER CALCULATE PAYMENT FOR SI G & K LINES *
      *              (DRUGS) IN PRICER; NOW CALCULATED IN FISS      *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 20550-CALC-RU
                         THRU 20550-CALC-RU-EXIT

                      IF PKG-BLD-DED-LINE
                         NEXT SENTENCE
                      END-IF

                      PERFORM 20560-CALC-BENE-DEDUCT
                         THRU 20560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 20550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      * 11/12/2008 - BRACHYTHERAPY SOURCE'S STATUS INDICATOR = ' U' *
      *              EFFECTIVE 1/1/2009                             *
      *                                                             *
      * 11/16/2009 - REMOVED LOGIC FOR THERAPEUTIC RADIOPHARMS &    *
      *              BRACHYTHERAPY SOURCES B/C THESE ARE NOT PAID   *
      *              AT COST FOR CY 2010                            *
      *                                                             *
      * 04/11/2011 - ADDED LOGIC TO PREVENT LINES WITH PAFS 9 OR 10 *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      * 05/13/2016 - ADDED LOGIC FOR BLOOD DEDUCTIBLE LINES ON A    *
      *              COMPREHENSIVE APC CLAIM (ZERO OUT REIM, COIN,  *
      *              & NON-BLOOD DEDUCTIBLE)                        *
      *                                                             *
      * 10/23/2018 - ADDED LOGIC TO PREVENT LINES W/PAFS 23  OR 24  *
      *              FROM RECEIVING COINSURANCE & MODIFIED          *
      *              REIMBURSEMENT CALCULATION FOR THESE LINES      *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * FOR BLOOD DEDUCTIBLE LINES ON A COMPREHENSIVE APC CLAIM:    *
      * SET REIMBURSEMENT, COINSURANCE, & DEDUCTIBLE AMOUNTS TO $0  *
      *-------------------------------------------------------------*
             IF PKG-BLD-DED-LINE
                MOVE 0 TO H-LITEM-REIM
                          H-TOTAL-LN-DEDUCT
                          H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 20550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * CALCULATE REIMBURSEMENT AND SET COINSURANCE AMOUNTS TO $0   *
      * FOR LINES WITH A PAF= 9 OR 10 OR 23 OR 24                   *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 9' OR '10' OR '23'
                                                OR '24')
                COMPUTE H-LITEM-REIM ROUNDED =
                   H-LITEM-PYMT - H-TOTAL-LN-DEDUCT
                MOVE 0 TO H-NAT-COIN
                          H-MIN-COIN
                          H-MAX-COIN
                          H-RED-COIN
                GO TO 20550-CALC-STANDARD-EXIT
             END-IF.

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                  H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX).
      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * FOR SECTION 603 SERVICES                                    *
      * SET MIN, MAX, AND REDUCED COINSURANCE TO PSF STANDARD       *
      * FOR LINES WITH A PMF= 7 OR 8 OR X OR Y                      *
      *-------------------------------------------------------------*
             IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '7' OR
                OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X' OR
                OPPS-SITE-SRVC-FLAG (LN-SUB) = '8' OR
                OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y'
                COMPUTE H-MIN-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                COMPUTE H-MAX-COIN ROUNDED =
                        H-LITEM-PYMT * COIN-RATE-20
                MOVE 0  TO H-RED-COIN
                GO TO 20550-CALC-STANDARD-EXIT
             END-IF.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DEVICES, BRACHYTHERAPY, & BLOOD                             *
      * (SI = H LINES HAVE A MIN-COIN = 0, WON'T ENTER LOGIC)       *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) =
                  ' H' OR ' R' OR ' U'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       20550-CALC-STANDARD-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE LINE'S DEVICE CREDIT AMOUNT                   *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - REVISED LOGIC IMPLEMENTED APRIL 2016           *
      *                                                             *
      ***************************************************************
       20550-DEVICE-CREDIT.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE CREDIT     *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-DEVCR-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-DEVCR-PYMTS.

           COMPUTE H-LINE-DEVCR-AMT ROUNDED =
                   H-CLAIM-DEVCR-AMT * H-LINE-DEVCR-PYMT-RATE.

       20550-DEVICE-CREDIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE TERMINATED PROCEDURE LINE'S DEVICE OFFSET     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 02/09/2016 - NEW FOR CY 2016 (APRIL IMPLEMENTATION)         *
      *                                                             *
      ***************************************************************
       20550-TERM-PROC-DEV-OFF.

      *-------------------------------------------------------------*
      * CALCULATE THE LINE'S PORTION OF THE CLAIM DEVICE OFFSET     *
      * FOR TERMINATED PROCEDURES                                   *
      *-------------------------------------------------------------*
           COMPUTE H-LINE-TPDO-PYMT-RATE ROUNDED =
                   W-APC-PYMT (W-LP-INDX) / H-TOT-TPDO-PYMTS.

           COMPUTE H-LINE-TPDO-AMT ROUNDED =
                   L-PAYER-ONLY-VC-QQ * H-LINE-TPDO-PYMT-RATE.

      *-------------------------------------------------------------*
      * ADJUST THE BASE APC PAYMENT BY THE DEVICE OFFSET            *
      *-------------------------------------------------------------*
           IF W-APC-PYMT (W-LP-INDX) >= H-LINE-TPDO-AMT
              COMPUTE W-APC-PYMT (W-LP-INDX) ROUNDED =
                      W-APC-PYMT (W-LP-INDX) - H-LINE-TPDO-AMT
           ELSE
              MOVE 0 TO W-APC-PYMT (W-LP-INDX)
           END-IF.

       20550-TERM-PROC-DEV-OFF-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *        FOR LINES WITH A SI OF S, V, T, P, X, R, OR U        *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA OR THE     *
      *   L-PSF-PYMT-CBSA MUST BE A VALUE OF                        *
      *   '   01' THRU '   99' AND THE L-PSF-PROV-TYPE              *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2017: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      * 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES (SI=R)     *
      *              ADDED TO LOGIC.  BRACHY LINES NOT PROCESSED IN *
      *              PARAGRAPH & NOW HAVE A SI = U, SI = K LOGIC    *
      *              REMOVED FROM THIS PARAGRAPH.                   *
      * 05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD    *
      *              DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.     *
      *              FIX EFFECTIVE RETROACTIVE TO 01/01/2009.       *
      * 11/17/2009 - BRACHYTHERAPY LINES NOW PROCESSED IN THIS      *
      *              PARAGRAPH FOR CY 2010 (SI=U), DO NOT RECEIVE   *
      *              WAGE ADJUSTMENT                                *
      * 05/09/2011 - REVISED LOGIC TO EXCLUDE BILL TYPE 14X FROM    *
      *              RECEIVING THE SCH ADD-ON                       *
      * 02/07/2012 - REPLACE BILL14X-FLAG WITH CONDITION NAME       *
      *              BILL-TYPE-14X                                  *
      * 01/27/2014 - WHEN APPLICABLE, SUBTRACT DEVICE CREDIT        *
      *              AMOUNT FROM LINE ITEM PAYMENT                  *
      * 10/21/2016 - EXCLUDE SECTION 603 SERVICE LINES FROM SCH ADJ *
      * 06/12/2017 - IF THE GEOGRAPHIC, WAGE INDEX, OR PAYMENT CBSA *
      *              IS RURAL, APPLY THE RURAL SCH ADJ. TO THE LINE *
      *              PAYMENT. ADDED L-PSF-PYMT-CBSA CY2017          *
      ***************************************************************
       20550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.
             MOVE L-PSF-PYMT-CBSA TO PYMT-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      *   - SECTION 603 SERVICES EXCLUDED FROM THE SCH ADJUSTMENT   *
      ***************************************************************

             IF (RURAL-GEO OR RURAL-WI OR RURAL-PYMT) AND
                (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22') AND
                (NOT BILL-TYPE-14X) AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '7') AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = 'X') AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = '8') AND
                (OPPS-SITE-SRVC-FLAG (LN-SUB) NOT = 'Y')
      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*

                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      ***************************************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = R (BLOOD) OR U (BRACHY) LINES ARE NOT WAGE-ADJUSTED    *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R' OR ' U'
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.
      *-------------------------------------------------------------*
      *   09/22/2020 - ADD PMF = 'B' RO MODEL ADJUSTMENT TO         *
      *   GEOGRAPHIC WAGE INDEX ADJUSTED AMOUNT, APPLY PMA BY       *
      *   MULTIPLICATION OF ADJUSTED WAGE INDEX.                    *
      *-------------------------------------------------------------*
             IF OPPS-SITE-SRVC-FLAG (LN-SUB) = 'B' AND
                      L-PSF-PYMT-MODEL-ADJ NUMERIC AND
                      L-PSF-PYMT-MODEL-ADJ > 0

                COMPUTE H-LITEM-PYMT ROUNDED =
                        H-LITEM-PYMT * L-PSF-PYMT-MODEL-ADJ
             END-IF.

      *-------------------------------------------------------------*
      * REDUCE ADJUSTED APC PAYMENT BY DEVICE CREDIT IF APPLICABLE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '17' AND
                H-LINE-DEVCR-AMT > 0
                IF H-LITEM-PYMT >= H-LINE-DEVCR-AMT
                   COMPUTE H-LITEM-PYMT ROUNDED =
                           H-LITEM-PYMT - H-LINE-DEVCR-AMT
                ELSE
                   MOVE 0 TO H-LITEM-PYMT
                END-IF
             END-IF.


       20550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = R & U LINES:         *
      *   - APC PAYMENT FOR BLOOD LINES (SI = R)                    *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = U LINES                      *
      *   - SCH ADJUSTMENT APPLIED TO BLOOD & BRACHY LINES          *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      * - 11/12/2008 - FOR CY 2009, BRACHYS NOT PROCESSED IN THIS   *
      *   PARAGRAPH; BRACHY LINES ASSIGNED A NEW SI OF ' U'         *
      * - 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES HAVE A   *
      *   SI = R                                                    *
      * - 12/05/2008 - MODIFIED LOGIC TO SEND BLOOD LINES WITHOUT   *
      *   A PMT ADJ FLAG = 5 OR 6 TO THE SCH ADJUSTMENT PARAGRAPH,  *
      *   INCLUDED SI = R IN THE BLOOD IDENTIFICATION LOGIC         *
      * - 11/15/2009 - BRACHYTHERPY SERVICES (SI = U) & THERAPEUTIC *
      *   RADIOPHARMS (SI = K) SENT TO THIS PARAGRAPH FOR CY 2010,  *
      *   LOGIC ALTERED TO PROCESS SI = U (RECEIVE REGULAR APC PMT) *
      * - 11/17/2009 - SEND BRACHYTHERAPY LINES TO 10550-SCH-ADJ TO *
      *   MAKE ELIGIBLE FOR SCH ADJUSTMENT, NOT WAGE ADJUSTED       *
      * - 05/10/2016 - ADDED LOGIC FOR SPECIAL HANDLING OF BLOOD    *
      *   DEDUCTIBLE LINES ON CLAIMS WITH A COMPREHENSIVE APC       *
      * - 11/2016 - REMOVED LOGIC FOR SI = G & K LINES (DRUGS)      *
      *                                                             *
      ***************************************************************
       20550-CALC-RU.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 20550-SET-BLOOD-FRACTION
                     THRU 20550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 20550-ADJ-BLOOD-COST
                     THRU 20550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 20550-SCH-ADJ
                     THRU 20550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * CHANGE THE PAYMENT OF THE BLOOD DEDUCTIBLE LINE ON THE SAME *
      * CLAIM AS A COMPREHENSIVE APC TO THE BLOOD DEDUCTIBLE AMOUNT *
      *-------------------------------------------------------------*
                  IF PKG-BLD-DED-LINE
                      MOVE H-LN-BLOOD-DEDUCT TO H-LITEM-PYMT
                  END-IF

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE, BUT PAF = 5 OR 6           *
      * (BLOOD PROCESSING AND PRODUCT BILLED TOGETHER)              *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 20550-ADJ-PLATE-COST
                      THRU 20550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 20550-SCH-ADJ
                      THRU 20550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE AND PAF NOT EQUAL TO 5 OR 6 *
      * (ONLY BLOOD PRODUCT BILLED)                                 *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 12/05/2008 - 7550-SCH-ADJ PERFORM ADDED FOR BLOOD LINES     *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 20550-SCH-ADJ
                      THRU 20550-SCH-ADJ-EXIT
                ELSE
                   IF OPPS-SRVC-IND (LN-SUB) = ' U'
                      PERFORM 20550-SCH-ADJ
                         THRU 20550-SCH-ADJ-EXIT
                   END-IF
                END-IF
             END-IF
             END-IF.

       20550-CALC-RU-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       20550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       20550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       20550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       20550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       20550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       20550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *           CALCULATE PAYMENT FOR PAID AT COST LINES          *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 08-11-2010 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED       *
      * 11-17-2015 - PASS-THROUGH DEVICE OFFSET LOGIC REVISED AGAIN *
      * 08-18-2016 - USE DEVICE CCR WHEN AVAILABLE                  *
      *                                                             *
      ***************************************************************
       20555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST - "PAID AT COST"         *
      * (IF NO DEVICE CCR USE HOSPITAL CCR)                         *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

              IF L-PSF-DEVICE-CCR = 0
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG *  L-PSF-OPCOST-RATIO)
              ELSE
                 COMPUTE T-LITEM-PYMT ROUNDED =
                         (H-SUB-CHRG * L-PSF-DEVICE-CCR)
              END-IF.

      *-------------------------------------------------------------*
      * FOR PASS-THROUGH DEVICE LINE WITH AN ASSOCIATED OFFSET,     *
      * APPLY THE OFFSET (INDICATED BY PAF = '12' OR '13' OR '15'   *
      * (NOT CURRENTLY USING PAF '15')                              *
      *-------------------------------------------------------------*
              IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12' OR
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13' OR
      *          OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
                 PERFORM 20556-CALC-PTD-OFFSET
                    THRU 20556-CALC-PTD-OFFSET-EXIT
              END-IF.

      *-------------------------------------------------------------*
      * CAPTURE PAYMENT AMOUNT                                      *
      *-------------------------------------------------------------*
             IF T-LITEM-PYMT < 0 THEN
                MOVE 0 TO H-LITEM-PYMT
             ELSE
                MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

       20555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *   REDUCE LINE ITEM PAYMENTS OF PASS-THROUGH DEVICES THAT    *
      * HAVE AN ASSOCIATED PROCEDURE ON THE CLAIM BY THE PROCEDURE  *
      *                WAGE-ADJUSTED OFFSET AMOUNT                  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ** EFFECTIVE 11/13/2015 - REVISED PT DEVICE OFFSET LOGIC    *
      *                                                             *
      ***************************************************************
       20556-CALC-PTD-OFFSET.

      *-------------------------------------------------------------*
      * DETERMINE WHICH VARIABLES TO USE IN CALCULATIONS            *
      *-------------------------------------------------------------*
            INITIALIZE H-TOT-PTD-CHARGES
                       H-WA-PTD-OFFSET.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '12'
               MOVE H-QN-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QN-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

            IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '13'
               MOVE H-QO-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
               MOVE H-QO-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
            END-IF.

      *-------------------------------------------------------------*
      * TO BE IMPLEMENTED IN A FUTURE RELEASE (AFTER JULY 2016)     *
      *-------------------------------------------------------------*
      *     IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = '15'
      *        MOVE H-QP-TOT-PTD-CHARGES TO H-TOT-PTD-CHARGES
      *        MOVE H-QP-WA-PTD-OFFSET   TO H-WA-PTD-OFFSET
      *     END-IF.

      *-------------------------------------------------------------*
      * DETERMINE WHAT % OF THE OFFSET WILL BE APPLIED              *
      *-------------------------------------------------------------*
            IF H-TOT-PTD-CHARGES > 0
               COMPUTE W-PTDO-CHRG-RATE ROUNDED =
                       H-SUB-CHRG / H-TOT-PTD-CHARGES
            ELSE
               GO TO 20556-CALC-PTD-OFFSET-EXIT
            END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE TAKEN                     *
      *-------------------------------------------------------------*
            COMPUTE W-PTDO-LINE-OFFSET ROUNDED =
                    W-PTDO-CHRG-RATE *
                    H-WA-PTD-OFFSET.

      *-------------------------------------------------------------*
      * SUBTRACT THE OFFSET AMOUNT FROM THE LINE PAYMENT            *
      *-------------------------------------------------------------*
            IF W-PTDO-LINE-OFFSET <= T-LITEM-PYMT
               COMPUTE T-LITEM-PYMT ROUNDED =
                       T-LITEM-PYMT - W-PTDO-LINE-OFFSET
            ELSE
               MOVE 0 TO T-LITEM-PYMT
            END-IF.


       20556-CALC-PTD-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       20560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * LINES INELIGIBLE FOR DEDUCTIBLE SKIP DEDUCTIBLE CALCULATION *
      * EFF. 7/1/2009 - CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      * ASSIGNED A PAF = ' 4'                                       *
      * - 04/11/2011 - ADDED PAF 9 FOR SERVICES WHERE THE           *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *   (ADDED FOR PREVENTIVE SERVICES WAIVER IN CY 2011)         *
      * - 10/23/2018 - ADDED PAF 23 & 24  FOR SERVICES WHERE THE    *
      *   DEDUCTIBLE AND CO-INSURANCE ARE NOT APPLICABLE            *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 4' OR ' 9' OR '23'
                                                OR '24')
                GO TO 20560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       20560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      * - 11/12/2008: FOR CY 2009, BRACHYS SI = U AND BLOOD SI = R  *
      *   BRACHY INELIGIBLE FOR OUTLIER, BLOOD ELIGIBLE FOR OUTLIER *
      *                                                             *
      * - 12/05/2008: ADDED SI = K TO LIST OF SIS INELIGIBLE FOR    *
      *   OUTLIER (BRACHYS & BLOOD NO LONGER HAVE SI = K)           *
      *                                                             *
      * - 11/17/2009: REMOVED U FROM LIST OF SIS INELIGIBLE FOR     *
      *   OUTLIER; BRACHYS NOW ELIGIBLE B/C NOT PAID AT COST CY 2010*
      *                                                             *
      * - 12/16/2009: ADDED SIS R AND U TO LOGIC THAT DISTRIBUTES   *
      *   PACKAGED CHARGES TO PAYABLE LINES. V2010.1.2              *
      *                                                             *
      * - 11/04/2011: MODIFIED LOGIC TO APPLY THE PHP CAP ONLY TO   *
      *   PHP CMHC LINES, NOT PHP HOSPITAL LINES PER POLICY'S       *
      *   INSTRUCTIONS                                              *
      *                                                             *
      * - 11/17/2015: MODIFIED LOGIC TO STOP ACCOUNTING FOR         *
      *   PASS-THROUGH DEVICE PAYMENTS AND CHARGES IN ASSOCIATED    *
      *   PROCEDURE'S OUTLIER CALCULATION.  ADDED STATUS INDICATOR  *
      *   'J2' AS ELIGIBLE FOR OUTLIER AND TO RECEIVED PACKAGED     *
      *   CHARGES                                                   *
      *                                                             *
      * - 05/10/2016: ADDED LOGIC TO EXCLUDE LINES ELIGIBLE FOR THE *
      *   BLOOD DEDUCTIBLE AND ON A CLAIM WITH A COMPREHENSIVE APC  *
      *   FROM THE OUTLIER PAYMENT                                  *
      *                                                             *
      * - 10/21/2016: ADDED LOGIC TO EXCLUDE SECTION 603 SERVICE    *
      *   LINES FROM THE OUTLIER PAYMENT (PMF = 7 OR 8)             *
      *                                                             *
      ***************************************************************
       20600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * SERVICE LINES NOT ELIGIBLE FOR AN OUTLIER PAYMENT:          *
      *   DEVICES, PACKAGED, PACKAGED AS PART OF DRUG ADMIN, AND    *
      *   SECTION 603 SERVICES,RO MODEL SERVICES                    *
      *-------------------------------------------------------------*
      * 11/12/2008 - BRACHY (SI=U) ADDED TO LIST                    *
      * 12/05/2008 - SI K ADDED TO THE LIST                         *
      * 11/16/2009 - REMOVED PAF=2 FROM BRACHY (SI=U) CRITERIA      *
      * 11/17/2009 - REMOVE SI=U, BRACHYS ARE ELIGIBLE FOR OUTLIER  *
      * 07/26/2016 - REMOVE SI=G SI=K                               *
      * 10/21/2016 - SECTION ADDED 603 SERVICES (PMF = 7 OR 8)      *
      * 12/02/2019 - SECTION ADDED 603 SERVICES (PMF = X OR Y)      *
      * 09/22/2020 - SECTION ADDED RO MODEL SERVICES (PMF = B)      *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' H' OR ' N') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '7') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'X') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = '8') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'Y') OR
                (OPPS-SITE-SRVC-FLAG (LN-SUB) = 'B')
                   GO TO 20600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * BLOOD LINES ELIGIBLE FOR THE BLOOD DEDUCTIBLE AND ON A      *
      * CLAIM WITH A COMPREHENSIVE APC NOT ELIGIBLE FOR OUTLIER     *
      *-------------------------------------------------------------*
      * 05/10/2016 - NEW FOR JULY 2016                              *
      *-------------------------------------------------------------*
             IF C-APC-CLAIM-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' AND
                OPPS-SRVC-IND (LN-SUB) = ' R'
                  GO TO 20600-ADJ-CHRG-OUTL-EXIT
             END-IF.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                           ' X' OR ' P' OR ' R' OR
                                           ' U' OR 'J1' OR 'J2') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * *** ENSURE ALL SIS ELIGIBLE FOR AN OUTLIER PAYMENT ARE  *** *
      * *** LISTED IN THE LOGIC BELOW AND IN THE SUMMING LOGIC  *** *
      * *** IN PARAGRAPH _500-ADJ-CHRGS.                        *** *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
      * 12/16/2009 - ADDED SIS R AND U TO LOGIC                     *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                          ' X' OR ' P' OR ' R' OR
                                          ' U' OR 'J1' OR 'J2') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A COMPOSITE ADJ.     *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 01 - NN...) ARE ACCUMULATED BY COMPOSITE            *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME        *
      * (PAYABLE) LINE'S CHARGES.                                   *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2007 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      * 11/12/2008 - CHANGED LOGIC TO USE THE COMPOSITE ADJUSTMENT  *
      *              FLAG INSTEAD OF THE PAYMENT ADJUSTMENT FLAG    *
      *              VALUES 91 - 99 TO ID PRIME COMPOSITE LINES     *
      ***************************************************************

      *-------------------------------------------------------------*
      * COMPOSITE ADJUSTMENT FLAG > 0 INDICATES COMPOSITE APC       *
      *-------------------------------------------------------------*
           IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = '00'

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.


      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD                          *
      *   (ALWAYS USE THE PHP "CAP" APC'S WAGE ADJ PMT FOR PHP LINES*
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED BECAUSE PAYMENTS MAY BE ADJUSTED FOR     *
      *              PASS-THROUGH DEVICES                           *
      * ??/??/2008 - NEW FOR CY 2009 - ALWAYS USE THE PHP "CAP"     *
      *              APC'S WAGE ADJ "CAP" PMT FOR PHP LINES (SI=P)  *
      * 11/04/2011 - ONLY APPLY PHP "CAP" TO CMHC LINES; PER        *
      *              POLICY'S INSTRUCTIONS PHP HOSPITAL LINES ARE   *
      *              NOT CAPPED.                                    *
      * 11/17/2015 - CONTINUE TO USE THIS LOGIC EVEN THOUGH PAYMENTS*
      *              ARE NO LONGER ADJUSTED FOR PT DEVICES          *
      * 10/26/2016 - DISABLED CMHC PHP PMT CAP BECAUSE ALL PHP CMHCS*
      *              USE THE SAME APC EFFECTIVE JANUARY 2017        *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL.


      ***************************************************************
      *                                                             *
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      * -NEW FOR JANUARY 2009                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE PHP "CAP" APC'S LINE PAYMENT                        *
      *                                                             *
      * -NEW FOR JANUARY 2017                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE SAME PHP APC (NO NEED TO CAP PMT)                   *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      * (CMHC PROVIDERS ONLY PROCESS PARTIAL HOSPITALIZATION LINES) *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT

      ***************************************************************
      *     ADD LOGIC TO PREVENT NEGATIVE OUTLIER PAYMENT           *
      ***************************************************************
                   IF H-LITEM-OUTL-PYMT < 0
                      MOVE 0 TO H-LITEM-OUTL-PYMT
                   END-IF


      *-------------------------------------------------------------*
      *     FOR CMHC PROVIDERS THAT ARE SUBJECT TO THE OUTLIER CAP, *
      *     ACCUMULATE CLAIM PAYMENT AND OUTLIER TOTALS             *
      * 12/02/2019 - ADDED PMF = 'Z'                                *
      *-------------------------------------------------------------*
                   IF OPPS-SITE-SRVC-FLAG (LN-SUB) = '0' OR 'Z'
                        COMPUTE H-CMHC-PYMT-TOTAL =
                          H-CMHC-PYMT-TOTAL + H-LITEM-PYMT-OUTL

                        COMPUTE H-CMHC-OUTL-TOTAL =
                          H-CMHC-OUTL-TOTAL + H-LITEM-OUTL-PYMT
                   END-IF

      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * 12/08/2020 - OUTLIER THRESHOLD AMOUNT 5300                  *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE

                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 5300)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT
                  END-IF
               END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT.


      *-------------------------------------------------------------*
      * LINES THAT ARE NOT ELIGIBLE FOR AN OUTLIER PAYMENT BECAUSE  *
      * OUTLIER CAP WAS MET BEFORE THIS CLAIM WAS PROCESSED -       *
      * ZERO OUT LINE OUTLIER PAYMENT & REMOVE FROM CLAIM TOTAL     *
      * 8/21/16 -MOVE 2 TO RETURN CODE, IF FLAG = 6 & OUTL PYMT > 0 *
      *-------------------------------------------------------------*
             IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '6')
                AND H-LITEM-OUTL-PYMT > 0
                COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                        H-LITEM-OUTL-PYMT
                MOVE 0 TO H-LITEM-OUTL-PYMT
                MOVE 02 TO A-CLM-RTN-CODE.


       20600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *               CAP CMHC TOTAL OUTLIER PAYMENTS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      * FOR CMHC CLAIMS ONLY, DO THE FOLLOWING:                     *
      *                                                             *
      * - DETERMINE IF THE TOTAL CLAIM OUTLIER PAYMENT ELIGIBLE     *
      *   FOR CAPPING IS > $0                                       *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS PAYMENTS INCLUDING THE *
      *   CURRENT CLAIM'S PAYMENTS                                  *
      * - CALCULATE THE CMHC'S TOTAL CY OPPS OUTLIER PAYMENTS       *
      *   INCLUDING THE CURRENT CLAIM'S OUTLIER PAYMENTS            *
      * - CALCULATE THE CURRENT OUTLIER PERCET                      *
      * - IF THE OUTLIER PERCENT EXCEEDS THE CAP:                   *
      *   - SET THE CLAIM OUTLIER TO $0                             *
      *   - SET THE RETURN CODE TO 02                               *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JULY 2017, EFFECTIVE JANUARY 2017                 *
      *                                                             *
      ***************************************************************
       20610-CMHC-OUTL-CAP.
             IF ( (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999') ) AND
                H-CMHC-OUTL-TOTAL > 0

      *-------------------------------------------------------------*
      *            CALCULATE PROVIDER'S TOTAL PAYMENTS              *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-PYMT-TOTAL =  H-CMHC-PYMT-TOTAL +
                        L-PRIOR-PYMT-TOTAL

      *-------------------------------------------------------------*
      *       CALCULATE PROVIDER'S TOTAL OUTLIER PAYMENTS           *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTL-TOTAL =  H-CMHC-OUTL-TOTAL +
                        L-PRIOR-OUTL-TOTAL

      *-------------------------------------------------------------*
      *                 CALCULATE OUTLIER PERCENT                   *
      *-------------------------------------------------------------*
                COMPUTE H-CMHC-OUTLIER-PCT ROUNDED =
                   H-CMHC-OUTL-TOTAL / H-CMHC-PYMT-TOTAL

      *-------------------------------------------------------------*
      *                     APPLY OUTLIER CAP                       *
      *-------------------------------------------------------------*
                IF H-CMHC-OUTLIER-PCT > CMHC-OUTL-CAP-PCT
                   MOVE 0 TO H-OUTLIER-PYMT
                   MOVE 02 TO A-CLM-RTN-CODE
                END-IF
             END-IF.

       20610-CMHC-OUTL-CAP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 20550-CALC-RU &        *
      *      20550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES        *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       20655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9010' OR
                                    'P9021' OR
                                    'P9051' OR
                                    'P9016' OR
                                    'P9038' OR
                                    'P9056' OR
                                    'P9057' OR
                                    'P9058' OR
                                    'P9040' OR
                                    'P9054' OR
                                    'P9039' OR
                                    'P9022'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       20655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *        PROCESS COINSURANCE CAP ROLL-UP TABLE RECORDS        *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE BLOOD LINE COINSURANCE WHEN THE PROCEDURE       *
      *  COINSURANCE AMOUNTS PLUS THE BLOOD COINSURANCE AMOUNT(S)   *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       20800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 20810-PROCESS-TYPE1
                   THRU 20810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 20840-PROCESS-TYPE2
                   THRU 20840-PROCESS-TYPE2-EXIT.

       20800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH BLOOD COINSURANCE, DETERMINE THE  *
      *  % OF TOTAL BLOOD COINSURANCE THAT CAN BE PAID IN ADDITION  *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE BLOOD COINSURANCE CAN BE PAID*
      *  WHEN H-RATIO = 1, ALL OF THE BLOOD COINSURANCE CAN BE PAID *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       20810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * BLOOD WAS ADMINISTERED ON THE DAY                           *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & ACTUAL COINSURANCE OF THE             *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-COIN1 (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL BLOOD COIN THAT CAN BE   *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      * CHANGED NATIONAL COINSURANCE TO ACTUAL COINSURANCE FOR      *
      * CY2018                                                      *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-COIN1 (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S BLOOD COIN CAN BE PAID B/C THE PROCEDURE/ *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL BLOOD COINSURANCE CAN BE PAID WITHIN THE    *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       20810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE BLOOD LINE'S NATIONAL COINSURANCE AMOUNT AND    *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       20840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 BLOOD COIN REC HAS SAME DATE OF SERVICE AS   *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE BLOOD COIN RECORD*
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE BLOOD LINE BY  *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD BLOOD COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT   *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       20840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       20900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       20900-END-PRICE-RTN-EXIT.
           EXIT.





